1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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
;
42 with Mutably_Tagged
; use Mutably_Tagged
;
43 with Namet
; use Namet
;
44 with Namet
.Sp
; use Namet
.Sp
;
45 with Nlists
; use Nlists
;
46 with Nmake
; use Nmake
;
48 with Output
; use Output
;
49 with Restrict
; use Restrict
;
50 with Rident
; use Rident
;
51 with Rtsfind
; use Rtsfind
;
53 with Sem_Aux
; use Sem_Aux
;
54 with Sem_Cat
; use Sem_Cat
;
55 with Sem_Ch3
; use Sem_Ch3
;
56 with Sem_Ch4
; use Sem_Ch4
;
57 with Sem_Ch6
; use Sem_Ch6
;
58 with Sem_Ch10
; use Sem_Ch10
;
59 with Sem_Ch12
; use Sem_Ch12
;
60 with Sem_Ch13
; use Sem_Ch13
;
61 with Sem_Dim
; use Sem_Dim
;
62 with Sem_Disp
; use Sem_Disp
;
63 with Sem_Dist
; use Sem_Dist
;
64 with Sem_Elab
; use Sem_Elab
;
65 with Sem_Eval
; use Sem_Eval
;
66 with Sem_Prag
; use Sem_Prag
;
67 with Sem_Res
; use Sem_Res
;
68 with Sem_Util
; use Sem_Util
;
69 with Sem_Type
; use Sem_Type
;
70 with Stand
; use Stand
;
71 with Sinfo
; use Sinfo
;
72 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
73 with Sinfo
.Utils
; use Sinfo
.Utils
;
74 with Sinfo
.CN
; use Sinfo
.CN
;
75 with Snames
; use Snames
;
78 with Tbuild
; use Tbuild
;
79 with Uintp
; use Uintp
;
80 with Warnsw
; use Warnsw
;
82 package body Sem_Ch8
is
84 ------------------------------------
85 -- Visibility and Name Resolution --
86 ------------------------------------
88 -- This package handles name resolution and the collection of possible
89 -- interpretations for overloaded names, prior to overload resolution.
91 -- Name resolution is the process that establishes a mapping between source
92 -- identifiers and the entities they denote at each point in the program.
93 -- Each entity is represented by a defining occurrence. Each identifier
94 -- that denotes an entity points to the corresponding defining occurrence.
95 -- This is the entity of the applied occurrence. Each occurrence holds
96 -- an index into the names table, where source identifiers are stored.
98 -- Each entry in the names table for an identifier or designator uses the
99 -- Info pointer to hold a link to the currently visible entity that has
100 -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id
101 -- in package Sem_Util). The visibility is initialized at the beginning of
102 -- semantic processing to make entities in package Standard immediately
103 -- visible. The visibility table is used in a more subtle way when
104 -- compiling subunits (see below).
106 -- Entities that have the same name (i.e. homonyms) are chained. In the
107 -- case of overloaded entities, this chain holds all the possible meanings
108 -- of a given identifier. The process of overload resolution uses type
109 -- information to select from this chain the unique meaning of a given
112 -- Entities are also chained in their scope, through the Next_Entity link.
113 -- As a consequence, the name space is organized as a sparse matrix, where
114 -- each row corresponds to a scope, and each column to a source identifier.
115 -- Open scopes, that is to say scopes currently being compiled, have their
116 -- corresponding rows of entities in order, innermost scope first.
118 -- The scopes of packages that are mentioned in context clauses appear in
119 -- no particular order, interspersed among open scopes. This is because
120 -- in the course of analyzing the context of a compilation, a package
121 -- declaration is first an open scope, and subsequently an element of the
122 -- context. If subunits or child units are present, a parent unit may
123 -- appear under various guises at various times in the compilation.
125 -- When the compilation of the innermost scope is complete, the entities
126 -- defined therein are no longer visible. If the scope is not a package
127 -- declaration, these entities are never visible subsequently, and can be
128 -- removed from visibility chains. If the scope is a package declaration,
129 -- its visible declarations may still be accessible. Therefore the entities
130 -- defined in such a scope are left on the visibility chains, and only
131 -- their visibility (immediately visibility or potential use-visibility)
134 -- The ordering of homonyms on their chain does not necessarily follow
135 -- the order of their corresponding scopes on the scope stack. For
136 -- example, if package P and the enclosing scope both contain entities
137 -- named E, then when compiling the package body the chain for E will
138 -- hold the global entity first, and the local one (corresponding to
139 -- the current inner scope) next. As a result, name resolution routines
140 -- do not assume any relative ordering of the homonym chains, either
141 -- for scope nesting or to order of appearance of context clauses.
143 -- When compiling a child unit, entities in the parent scope are always
144 -- immediately visible. When compiling the body of a child unit, private
145 -- entities in the parent must also be made immediately visible. There
146 -- are separate routines to make the visible and private declarations
147 -- visible at various times (see package Sem_Ch7).
149 -- +--------+ +-----+
150 -- | In use |-------->| EU1 |-------------------------->
151 -- +--------+ +-----+
153 -- +--------+ +-----+ +-----+
154 -- | Stand. |---------------->| ES1 |--------------->| ES2 |--->
155 -- +--------+ +-----+ +-----+
157 -- +---------+ | +-----+
158 -- | with'ed |------------------------------>| EW2 |--->
159 -- +---------+ | +-----+
161 -- +--------+ +-----+ +-----+
162 -- | Scope2 |---------------->| E12 |--------------->| E22 |--->
163 -- +--------+ +-----+ +-----+
165 -- +--------+ +-----+ +-----+
166 -- | Scope1 |---------------->| E11 |--------------->| E12 |--->
167 -- +--------+ +-----+ +-----+
171 -- | | with'ed |----------------------------------------->
175 -- (innermost first) | |
176 -- +----------------------------+
177 -- Names table => | Id1 | | | | Id2 |
178 -- +----------------------------+
180 -- Name resolution must deal with several syntactic forms: simple names,
181 -- qualified names, indexed names, and various forms of calls.
183 -- Each identifier points to an entry in the names table. The resolution
184 -- of a simple name consists in traversing the homonym chain, starting
185 -- from the names table. If an entry is immediately visible, it is the one
186 -- designated by the identifier. If only potentially use-visible entities
187 -- are on the chain, we must verify that they do not hide each other. If
188 -- the entity we find is overloadable, we collect all other overloadable
189 -- entities on the chain as long as they are not hidden.
191 -- To resolve expanded names, we must find the entity at the intersection
192 -- of the entity chain for the scope (the prefix) and the homonym chain
193 -- for the selector. In general, homonym chains will be much shorter than
194 -- entity chains, so it is preferable to start from the names table as
195 -- well. If the entity found is overloadable, we must collect all other
196 -- interpretations that are defined in the scope denoted by the prefix.
198 -- For records, protected types, and tasks, their local entities are
199 -- removed from visibility chains on exit from the corresponding scope.
200 -- From the outside, these entities are always accessed by selected
201 -- notation, and the entity chain for the record type, protected type,
202 -- etc. is traversed sequentially in order to find the designated entity.
204 -- The discriminants of a type and the operations of a protected type or
205 -- task are unchained on exit from the first view of the type, (such as
206 -- a private or incomplete type declaration, or a protected type speci-
207 -- fication) and re-chained when compiling the second view.
209 -- In the case of operators, we do not make operators on derived types
210 -- explicit. As a result, the notation P."+" may denote either a user-
211 -- defined function with name "+", or else an implicit declaration of the
212 -- operator "+" in package P. The resolution of expanded names always
213 -- tries to resolve an operator name as such an implicitly defined entity,
214 -- in addition to looking for explicit declarations.
216 -- All forms of names that denote entities (simple names, expanded names,
217 -- character literals in some cases) have a Entity attribute, which
218 -- identifies the entity denoted by the name.
220 ---------------------
221 -- The Scope Stack --
222 ---------------------
224 -- The Scope stack keeps track of the scopes currently been compiled.
225 -- Every entity that contains declarations (including records) is placed
226 -- on the scope stack while it is being processed, and removed at the end.
227 -- Whenever a non-package scope is exited, the entities defined therein
228 -- are removed from the visibility table, so that entities in outer scopes
229 -- become visible (see previous description). On entry to Sem, the scope
230 -- stack only contains the package Standard. As usual, subunits complicate
231 -- this picture ever so slightly.
233 -- The Rtsfind mechanism can force a call to Semantics while another
234 -- compilation is in progress. The unit retrieved by Rtsfind must be
235 -- compiled in its own context, and has no access to the visibility of
236 -- the unit currently being compiled. The procedures Save_Scope_Stack and
237 -- Restore_Scope_Stack make entities in current open scopes invisible
238 -- before compiling the retrieved unit, and restore the compilation
239 -- environment afterwards.
241 ------------------------
242 -- Compiling subunits --
243 ------------------------
245 -- Subunits must be compiled in the environment of the corresponding stub,
246 -- that is to say with the same visibility into the parent (and its
247 -- context) that is available at the point of the stub declaration, but
248 -- with the additional visibility provided by the context clause of the
249 -- subunit itself. As a result, compilation of a subunit forces compilation
250 -- of the parent (see description in lib-). At the point of the stub
251 -- declaration, Analyze is called recursively to compile the proper body of
252 -- the subunit, but without reinitializing the names table, nor the scope
253 -- stack (i.e. standard is not pushed on the stack). In this fashion the
254 -- context of the subunit is added to the context of the parent, and the
255 -- subunit is compiled in the correct environment. Note that in the course
256 -- of processing the context of a subunit, Standard will appear twice on
257 -- the scope stack: once for the parent of the subunit, and once for the
258 -- unit in the context clause being compiled. However, the two sets of
259 -- entities are not linked by homonym chains, so that the compilation of
260 -- any context unit happens in a fresh visibility environment.
262 -------------------------------
263 -- Processing of USE Clauses --
264 -------------------------------
266 -- Every defining occurrence has a flag indicating if it is potentially use
267 -- visible. Resolution of simple names examines this flag. The processing
268 -- of use clauses consists in setting this flag on all visible entities
269 -- defined in the corresponding package. On exit from the scope of the use
270 -- clause, the corresponding flag must be reset. However, a package may
271 -- appear in several nested use clauses (pathological but legal, alas)
272 -- which forces us to use a slightly more involved scheme:
274 -- a) The defining occurrence for a package holds a flag -In_Use- to
275 -- indicate that it is currently in the scope of a use clause. If a
276 -- redundant use clause is encountered, then the corresponding occurrence
277 -- of the package name is flagged -Redundant_Use-.
279 -- b) On exit from a scope, the use clauses in its declarative part are
280 -- scanned. The visibility flag is reset in all entities declared in
281 -- package named in a use clause, as long as the package is not flagged
282 -- as being in a redundant use clause (in which case the outer use
283 -- clause is still in effect, and the direct visibility of its entities
284 -- must be retained).
286 -- Note that entities are not removed from their homonym chains on exit
287 -- from the package specification. A subsequent use clause does not need
288 -- to rechain the visible entities, but only to establish their direct
291 -----------------------------------
292 -- Handling private declarations --
293 -----------------------------------
295 -- The principle that each entity has a single defining occurrence clashes
296 -- with the presence of two separate definitions for private types: the
297 -- first is the private type declaration, and second is the full type
298 -- declaration. It is important that all references to the type point to
299 -- the same defining occurrence, namely the first one. To enforce the two
300 -- separate views of the entity, the corresponding information is swapped
301 -- between the two declarations. Outside of the package, the defining
302 -- occurrence only contains the private declaration information, while in
303 -- the private part and the body of the package the defining occurrence
304 -- contains the full declaration. To simplify the swap, the defining
305 -- occurrence that currently holds the private declaration points to the
306 -- full declaration. During semantic processing the defining occurrence
307 -- also points to a list of private dependents, that is to say access types
308 -- or composite types whose designated types or component types are
309 -- subtypes or derived types of the private type in question. After the
310 -- full declaration has been seen, the private dependents are updated to
311 -- indicate that they have full definitions.
313 ------------------------------------
314 -- Handling of Undefined Messages --
315 ------------------------------------
317 -- In normal mode, only the first use of an undefined identifier generates
318 -- a message. The table Urefs is used to record error messages that have
319 -- been issued so that second and subsequent ones do not generate further
320 -- messages. However, the second reference causes text to be added to the
321 -- original undefined message noting "(more references follow)". The
322 -- full error list option (-gnatf) forces messages to be generated for
323 -- every reference and disconnects the use of this table.
325 type Uref_Entry
is record
327 -- Node for identifier for which original message was posted. The
328 -- Chars field of this identifier is used to detect later references
329 -- to the same identifier.
332 -- Records error message Id of original undefined message. Reset to
333 -- No_Error_Msg after the second occurrence, where it is used to add
334 -- text to the original message as described above.
337 -- Set if the message is not visible rather than undefined
340 -- Records location of error message. Used to make sure that we do
341 -- not consider a, b : undefined as two separate instances, which
342 -- would otherwise happen, since the parser converts this sequence
343 -- to a : undefined; b : undefined.
347 package Urefs
is new Table
.Table
(
348 Table_Component_Type
=> Uref_Entry
,
349 Table_Index_Type
=> Nat
,
350 Table_Low_Bound
=> 1,
352 Table_Increment
=> 100,
353 Table_Name
=> "Urefs");
355 Candidate_Renaming
: Entity_Id
;
356 -- Holds a candidate interpretation that appears in a subprogram renaming
357 -- declaration and does not match the given specification, but matches at
358 -- least on the first formal. Allows better error message when given
359 -- specification omits defaulted parameters, a common error.
361 -----------------------
362 -- Local Subprograms --
363 -----------------------
365 procedure Analyze_Generic_Renaming
368 -- Common processing for all three kinds of generic renaming declarations.
369 -- Enter new name and indicate that it renames the generic unit.
371 procedure Analyze_Renamed_Character
375 -- Renamed entity is given by a character literal, which must belong
376 -- to the return type of the new entity. Is_Body indicates whether the
377 -- declaration is a renaming_as_body. If the original declaration has
378 -- already been frozen (because of an intervening body, e.g.) the body of
379 -- the function must be built now. The same applies to the following
380 -- various renaming procedures.
382 procedure Analyze_Renamed_Dereference
386 -- Renamed entity is given by an explicit dereference. Prefix must be a
387 -- conformant access_to_subprogram type.
389 procedure Analyze_Renamed_Entry
393 -- If the renamed entity in a subprogram renaming is an entry or protected
394 -- subprogram, build a body for the new entity whose only statement is a
395 -- call to the renamed entity.
397 procedure Analyze_Renamed_Family_Member
401 -- Used when the renamed entity is an indexed component. The prefix must
402 -- denote an entry family.
404 procedure Analyze_Renamed_Primitive_Operation
408 -- If the renamed entity in a subprogram renaming is a primitive operation
409 -- or a class-wide operation in prefix form, save the target object,
410 -- which must be added to the list of actuals in any subsequent call.
411 -- The renaming operation is intrinsic because the compiler must in
412 -- fact generate a wrapper for it (6.3.1 (10 1/2)).
414 procedure Attribute_Renaming
(N
: Node_Id
);
415 -- Analyze renaming of attribute as subprogram. The renaming declaration N
416 -- is rewritten as a subprogram body that returns the attribute reference
417 -- applied to the formals of the function.
419 procedure Set_Entity_Or_Discriminal
(N
: Node_Id
; E
: Entity_Id
);
420 -- Set Entity, with style check if need be. For a discriminant reference,
421 -- replace by the corresponding discriminal, i.e. the parameter of the
422 -- initialization procedure that corresponds to the discriminant.
424 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
);
425 -- A renaming_as_body may occur after the entity of the original decla-
426 -- ration has been frozen. In that case, the body of the new entity must
427 -- be built now, because the usual mechanism of building the renamed
428 -- body at the point of freezing will not work. Subp is the subprogram
429 -- for which N provides the Renaming_As_Body.
431 procedure Check_In_Previous_With_Clause
(N
, Nam
: Node_Id
);
432 -- N is a use_package clause and Nam the package name, or N is a use_type
433 -- clause and Nam is the prefix of the type name. In either case, verify
434 -- that the package is visible at that point in the context: either it
435 -- appears in a previous with_clause, or because it is a fully qualified
436 -- name and the root ancestor appears in a previous with_clause.
438 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
);
439 -- Verify that the entity in a renaming declaration that is a library unit
440 -- is itself a library unit and not a nested unit or subunit. Also check
441 -- that if the renaming is a child unit of a generic parent, then the
442 -- renamed unit must also be a child unit of that parent. Finally, verify
443 -- that a renamed generic unit is not an implicit child declared within
444 -- an instance of the parent.
446 procedure Chain_Use_Clause
(N
: Node_Id
);
447 -- Chain use clause onto list of uses clauses headed by First_Use_Clause in
448 -- the proper scope table entry. This is usually the current scope, but it
449 -- will be an inner scope when installing the use clauses of the private
450 -- declarations of a parent unit prior to compiling the private part of a
451 -- child unit. This chain is traversed when installing/removing use clauses
452 -- when compiling a subunit or instantiating a generic body on the fly,
453 -- when it is necessary to save and restore full environments.
455 function Enclosing_Instance
return Entity_Id
;
456 -- In an instance nested within another one, several semantic checks are
457 -- unnecessary because the legality of the nested instance has been checked
458 -- in the enclosing generic unit. This applies in particular to legality
459 -- checks on actuals for formal subprograms of the inner instance, which
460 -- are checked as subprogram renamings, and may be complicated by confusion
461 -- in private/full views. This function returns the instance enclosing the
462 -- current one if there is such, else it returns Empty.
464 -- If the renaming determines the entity for the default of a formal
465 -- subprogram nested within another instance, choose the innermost
466 -- candidate. This is because if the formal has a box, and we are within
467 -- an enclosing instance where some candidate interpretations are local
468 -- to this enclosing instance, we know that the default was properly
469 -- resolved when analyzing the generic, so we prefer the local
470 -- candidates to those that are external. This is not always the case
471 -- but is a reasonable heuristic on the use of nested generics. The
472 -- proper solution requires a full renaming model.
474 function Entity_Of_Unit
(U
: Node_Id
) return Entity_Id
;
475 -- Return the appropriate entity for determining which unit has a deeper
476 -- scope: the defining entity for U, unless U is a package instance, in
477 -- which case we retrieve the entity of the instance spec.
479 procedure Error_Missing_With_Of_Known_Unit
(Pkg
: Node_Id
);
480 -- Display an error message denoting a "with" is missing for a given known
481 -- package Pkg with its full path name.
483 procedure Find_Expanded_Name
(N
: Node_Id
);
484 -- The input is a selected component known to be an expanded name. Verify
485 -- legality of selector given the scope denoted by prefix, and change node
486 -- N into a expanded name with a properly set Entity field.
488 function Find_First_Use
(Use_Clause
: Node_Id
) return Node_Id
;
489 -- Find the most previous use clause (that is, the first one to appear in
490 -- the source) by traversing the previous clause chain that exists in both
491 -- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes.
493 function Find_Renamed_Entity
497 Is_Actual
: Boolean := False) return Entity_Id
;
498 -- Find the renamed entity that corresponds to the given parameter profile
499 -- in a subprogram renaming declaration. The renamed entity may be an
500 -- operator, a subprogram, an entry, or a protected operation. Is_Actual
501 -- indicates that the renaming is the one generated for an actual subpro-
502 -- gram in an instance, for which special visibility checks apply.
504 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean;
505 -- Find a type derived from Character or Wide_Character in the prefix of N.
506 -- Used to resolved qualified names whose selector is a character literal.
508 function Has_Private_With
(E
: Entity_Id
) return Boolean;
509 -- Ada 2005 (AI-262): Determines if the current compilation unit has a
510 -- private with on E.
512 function Has_Components
(Typ
: Entity_Id
) return Boolean;
513 -- Determine if given type has components, i.e. is either a record type or
514 -- type or a type that has discriminants.
516 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean;
517 -- N is an expanded name whose selector is an operator name (e.g. P."+").
518 -- Determine if N denotes an operator implicitly declared in prefix P: P's
519 -- declarative part contains an implicit declaration of an operator if it
520 -- has a declaration of a type to which one of the predefined operators
521 -- apply. The existence of this routine is an implementation artifact. A
522 -- more straightforward but more space-consuming choice would be to make
523 -- all inherited operators explicit in the symbol table.
525 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
);
526 -- A subprogram defined by a renaming declaration inherits the parameter
527 -- profile of the renamed entity. The subtypes given in the subprogram
528 -- specification are discarded and replaced with those of the renamed
529 -- subprogram, which are then used to recheck the default values.
531 function Most_Descendant_Use_Clause
532 (Clause1
: Entity_Id
;
533 Clause2
: Entity_Id
) return Entity_Id
;
534 -- Determine which use clause parameter is the most descendant in terms of
537 procedure Premature_Usage
(N
: Node_Id
);
538 -- Diagnose usage of an entity before it is visible
540 function Is_Self_Hidden
(E
: Entity_Id
) return Boolean;
541 -- True within a declaration if it is hidden from all visibility by itself
542 -- (see RM-8.3(16-18)). This is mostly just "not Is_Not_Self_Hidden", but
543 -- we need to check for E_Void in case of errors.
545 procedure Use_One_Package
547 Pack_Name
: Entity_Id
:= Empty
;
548 Force
: Boolean := False);
549 -- Make visible entities declared in package P potentially use-visible
550 -- in the current context. Also used in the analysis of subunits, when
551 -- re-installing use clauses of parent units. N is the use_clause that
552 -- names P (and possibly other packages).
554 procedure Use_One_Type
556 Installed
: Boolean := False;
557 Force
: Boolean := False);
558 -- Id is the subtype mark from a use_type_clause. This procedure makes
559 -- the primitive operators of the type potentially use-visible. The
560 -- boolean flag Installed indicates that the clause is being reinstalled
561 -- after previous analysis, and primitive operations are already chained
562 -- on the Used_Operations list of the clause.
564 procedure Write_Info
;
565 -- Write debugging information on entities declared in current scope
567 --------------------------------
568 -- Analyze_Exception_Renaming --
569 --------------------------------
571 -- The language only allows a single identifier, but the tree holds an
572 -- identifier list. The parser has already issued an error message if
573 -- there is more than one element in the list.
575 procedure Analyze_Exception_Renaming
(N
: Node_Id
) is
576 Id
: constant Entity_Id
:= Defining_Entity
(N
);
577 Nam
: constant Node_Id
:= Name
(N
);
583 Mutate_Ekind
(Id
, E_Exception
);
584 Set_Etype
(Id
, Standard_Exception_Type
);
585 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
587 if Is_Entity_Name
(Nam
)
588 and then Present
(Entity
(Nam
))
589 and then Ekind
(Entity
(Nam
)) = E_Exception
591 if Present
(Renamed_Entity
(Entity
(Nam
))) then
592 Set_Renamed_Entity
(Id
, Renamed_Entity
(Entity
(Nam
)));
594 Set_Renamed_Entity
(Id
, Entity
(Nam
));
597 -- The exception renaming declaration may become Ghost if it renames
600 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
602 Error_Msg_N
("invalid exception name in renaming", Nam
);
605 -- Implementation-defined aspect specifications can appear in a renaming
606 -- declaration, but not language-defined ones. The call to procedure
607 -- Analyze_Aspect_Specifications will take care of this error check.
609 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 Analyze_Aspect_Specifications
(N
, New_P
);
756 end Analyze_Generic_Renaming
;
758 -----------------------------
759 -- Analyze_Object_Renaming --
760 -----------------------------
762 procedure Analyze_Object_Renaming
(N
: Node_Id
) is
763 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
764 Loc
: constant Source_Ptr
:= Sloc
(N
);
765 Nam
: constant Node_Id
:= Name
(N
);
766 Is_Object_Ref
: Boolean;
772 procedure Check_Constrained_Object
;
773 -- If the nominal type is unconstrained but the renamed object is
774 -- constrained, as can happen with renaming an explicit dereference or
775 -- a function return, build a constrained subtype from the object. If
776 -- the renaming is for a formal in an accept statement, the analysis
777 -- has already established its actual subtype. This is only relevant
778 -- if the renamed object is an explicit dereference.
780 function Get_Object_Name
(Nod
: Node_Id
) return Node_Id
;
781 -- Obtain the name of the object from node Nod which is being renamed by
782 -- the object renaming declaration N.
784 function Find_Raise_Node
(N
: Node_Id
) return Traverse_Result
;
785 -- Process one node in search for N_Raise_xxx_Error nodes.
786 -- Return Abandon if found, OK otherwise.
788 ---------------------
789 -- Find_Raise_Node --
790 ---------------------
792 function Find_Raise_Node
(N
: Node_Id
) return Traverse_Result
is
794 if Nkind
(N
) in N_Raise_xxx_Error
then
801 ------------------------
802 -- No_Raise_xxx_Error --
803 ------------------------
805 function No_Raise_xxx_Error
is new Traverse_Func
(Find_Raise_Node
);
806 -- Traverse tree to look for a N_Raise_xxx_Error node and returns
807 -- Abandon if so and OK if none found.
809 ------------------------------
810 -- Check_Constrained_Object --
811 ------------------------------
813 procedure Check_Constrained_Object
is
814 Typ
: constant Entity_Id
:= Etype
(Nam
);
816 Loop_Scheme
: Node_Id
;
819 if Nkind
(Nam
) in N_Function_Call | N_Explicit_Dereference
820 and then Is_Composite_Type
(Typ
)
821 and then not Is_Constrained
(Typ
)
822 and then not Has_Unknown_Discriminants
(Typ
)
823 and then Expander_Active
825 -- If Actual_Subtype is already set, nothing to do
827 if Ekind
(Id
) in E_Variable | E_Constant
828 and then Present
(Actual_Subtype
(Id
))
832 -- A renaming of an unchecked union has no actual subtype
834 elsif Is_Unchecked_Union
(Typ
) then
837 -- If a record is limited its size is invariant. This is the case
838 -- in particular with record types with an access discriminant
839 -- that are used in iterators. This is an optimization, but it
840 -- also prevents typing anomalies when the prefix is further
843 -- Note that we cannot just use the Is_Limited_Record flag because
844 -- it does not apply to records with limited components, for which
845 -- this syntactic flag is not set, but whose size is also fixed.
847 -- Note also that we need to build the constrained subtype for an
848 -- array in order to make the bounds explicit in most cases, but
849 -- not if the object comes from an extended return statement, as
850 -- this would create dangling references to them later on.
852 elsif Is_Limited_Type
(Typ
)
853 and then (not Is_Array_Type
(Typ
) or else Is_Return_Object
(Id
))
858 Subt
:= Make_Temporary
(Loc
, 'T');
859 Remove_Side_Effects
(Nam
);
861 Make_Subtype_Declaration
(Loc
,
862 Defining_Identifier
=> Subt
,
863 Subtype_Indication
=>
864 Make_Subtype_From_Expr
(Nam
, Typ
)));
867 New_Subtype_Mark
: constant Node_Id
:=
868 New_Occurrence_Of
(Subt
, Loc
);
870 if Present
(Subtype_Mark
(N
)) then
871 Rewrite
(Subtype_Mark
(N
), New_Subtype_Mark
);
873 -- An Ada2022 renaming with no subtype mark
874 Set_Subtype_Mark
(N
, New_Subtype_Mark
);
878 Set_Etype
(Nam
, Subt
);
880 -- Suppress discriminant checks on this subtype if the original
881 -- type has defaulted discriminants and Id is a "for of" loop
884 if Has_Defaulted_Discriminants
(Typ
)
885 and then Nkind
(Original_Node
(Parent
(N
))) = N_Loop_Statement
887 Loop_Scheme
:= Iteration_Scheme
(Original_Node
(Parent
(N
)));
889 if Present
(Loop_Scheme
)
890 and then Present
(Iterator_Specification
(Loop_Scheme
))
893 (Iterator_Specification
(Loop_Scheme
)) = Id
895 Set_Checks_May_Be_Suppressed
(Subt
);
896 Push_Local_Suppress_Stack_Entry
898 Check
=> Discriminant_Check
,
903 -- Freeze subtype at once, to prevent order of elaboration
904 -- issues in the backend. The renamed object exists, so its
905 -- type is already frozen in any case.
907 Freeze_Before
(N
, Subt
);
910 end Check_Constrained_Object
;
912 ---------------------
913 -- Get_Object_Name --
914 ---------------------
916 function Get_Object_Name
(Nod
: Node_Id
) return Node_Id
is
921 while Present
(Obj_Nam
) loop
922 case Nkind
(Obj_Nam
) is
923 when N_Attribute_Reference
924 | N_Explicit_Dereference
925 | N_Indexed_Component
928 Obj_Nam
:= Prefix
(Obj_Nam
);
930 when N_Selected_Component
=>
931 Obj_Nam
:= Selector_Name
(Obj_Nam
);
933 when N_Qualified_Expression | N_Type_Conversion
=>
934 Obj_Nam
:= Expression
(Obj_Nam
);
944 -- Start of processing for Analyze_Object_Renaming
951 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
954 -- The renaming of a component that depends on a discriminant requires
955 -- an actual subtype, because in subsequent use of the object Gigi will
956 -- be unable to locate the actual bounds. This explicit step is required
957 -- when the renaming is generated in removing side effects of an
958 -- already-analyzed expression.
960 if Nkind
(Nam
) = N_Selected_Component
and then Analyzed
(Nam
) then
962 -- The object renaming declaration may become Ghost if it renames a
965 if Is_Entity_Name
(Nam
) then
966 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
970 Dec
:= Build_Actual_Subtype_Of_Component
(Etype
(Nam
), Nam
);
972 if Present
(Dec
) then
973 Insert_Action
(N
, Dec
);
974 T
:= Defining_Identifier
(Dec
);
977 elsif Present
(Subtype_Mark
(N
))
978 or else No
(Access_Definition
(N
))
980 if Present
(Subtype_Mark
(N
)) then
981 Find_Type
(Subtype_Mark
(N
));
982 T
:= Entity
(Subtype_Mark
(N
));
985 -- AI12-0275: Case of object renaming without a subtype_mark
990 -- Normal case of no overloading in object name
992 if not Is_Overloaded
(Nam
) then
994 -- Catch error cases (such as attempting to rename a procedure
995 -- or package) using the shorthand form.
998 or else Etype
(Nam
) = Standard_Void_Type
1001 ("object name or value expected in renaming", Nam
);
1003 Mutate_Ekind
(Id
, E_Variable
);
1004 Set_Etype
(Id
, Any_Type
);
1012 -- Case of overloaded name, which will be illegal if there's more
1013 -- than one acceptable interpretation (such as overloaded function
1025 -- More than one candidate interpretation is available
1027 -- Remove procedure calls, which syntactically cannot appear
1028 -- in this context, but which cannot be removed by type
1029 -- checking, because the context does not impose a type.
1031 Get_First_Interp
(Nam
, I
, It
);
1032 while Present
(It
.Typ
) loop
1033 if It
.Typ
= Standard_Void_Type
then
1037 Get_Next_Interp
(I
, It
);
1040 Get_First_Interp
(Nam
, I
, It
);
1044 -- If there's no type present, we have an error case (such
1045 -- as overloaded procedures named in the object renaming).
1049 ("object name or value expected in renaming", Nam
);
1051 Mutate_Ekind
(Id
, E_Variable
);
1052 Set_Etype
(Id
, Any_Type
);
1057 Get_Next_Interp
(I
, It
);
1059 if Present
(It
.Typ
) then
1061 It1
:= Disambiguate
(Nam
, I1
, I
, Any_Type
);
1063 if It1
= No_Interp
then
1064 Error_Msg_N
("ambiguous name in object renaming", Nam
);
1066 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
1067 Error_Msg_N
("\\possible interpretation#!", Nam
);
1069 Error_Msg_Sloc
:= Sloc
(Nam1
);
1070 Error_Msg_N
("\\possible interpretation#!", Nam
);
1076 Set_Etype
(Nam
, It1
.Typ
);
1081 if Etype
(Nam
) = Standard_Exception_Type
then
1083 ("exception requires a subtype mark in renaming", Nam
);
1088 -- The object renaming declaration may become Ghost if it renames a
1091 if Is_Entity_Name
(Nam
) then
1092 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
1095 -- Check against AI12-0401 here before Resolve may rewrite Nam and
1096 -- potentially generate spurious warnings.
1098 -- In the case where the object_name is a qualified_expression with
1099 -- a nominal subtype T and whose expression is a name that denotes
1101 -- * if T is an elementary subtype, then:
1102 -- * Q shall be a constant other than a dereference of an access
1104 -- * the nominal subtype of Q shall be statically compatible with
1106 -- * T shall statically match the base subtype of its type if
1107 -- scalar, or the first subtype of its type if an access type.
1108 -- * if T is a composite subtype, then Q shall be known to be
1109 -- constrained or T shall statically match the first subtype of
1112 if Nkind
(Nam
) = N_Qualified_Expression
1113 and then Is_Object_Reference
(Expression
(Nam
))
1115 Q
:= Expression
(Nam
);
1117 if (Is_Elementary_Type
(T
)
1119 not ((not Is_Variable
(Q
)
1120 and then Nkind
(Q
) /= N_Explicit_Dereference
)
1121 or else Subtypes_Statically_Compatible
(Etype
(Q
), T
)
1122 or else (Is_Scalar_Type
(T
)
1123 and then Subtypes_Statically_Match
1125 or else (Is_Access_Type
(T
)
1126 and then Subtypes_Statically_Match
1127 (T
, First_Subtype
(T
)))))
1128 or else (Is_Composite_Type
(T
)
1131 -- If Q is an aggregate, Is_Constrained may not be set
1132 -- yet and its type may not be resolved yet.
1133 -- This doesn't quite correspond to the complex notion
1134 -- of "known to be constrained" but this is good enough
1135 -- for a rule which is in any case too complex.
1137 not (Is_Constrained
(Etype
(Q
))
1138 or else Nkind
(Q
) = N_Aggregate
1139 or else Subtypes_Statically_Match
1140 (T
, First_Subtype
(T
))))
1143 ("subtype of renamed qualified expression does not " &
1144 "statically match", N
);
1151 -- If the renamed object is a function call of a limited type,
1152 -- the expansion of the renaming is complicated by the presence
1153 -- of various temporaries and subtypes that capture constraints
1154 -- of the renamed object. Rewrite node as an object declaration,
1155 -- whose expansion is simpler. Given that the object is limited
1156 -- there is no copy involved and no performance hit.
1158 if Nkind
(Nam
) = N_Function_Call
1159 and then Is_Inherently_Limited_Type
(Etype
(Nam
))
1160 and then not Is_Constrained
(Etype
(Nam
))
1161 and then Comes_From_Source
(N
)
1164 Mutate_Ekind
(Id
, E_Constant
);
1166 Make_Object_Declaration
(Loc
,
1167 Defining_Identifier
=> Id
,
1168 Constant_Present
=> True,
1169 Object_Definition
=> New_Occurrence_Of
(Etype
(Nam
), Loc
),
1170 Expression
=> Relocate_Node
(Nam
)));
1174 -- Ada 2012 (AI05-149): Reject renaming of an anonymous access object
1175 -- when renaming declaration has a named access type. The Ada 2012
1176 -- coverage rules allow an anonymous access type in the context of
1177 -- an expected named general access type, but the renaming rules
1178 -- require the types to be the same. (An exception is when the type
1179 -- of the renaming is also an anonymous access type, which can only
1180 -- happen due to a renaming created by the expander.)
1182 if Nkind
(Nam
) = N_Type_Conversion
1183 and then not Comes_From_Source
(Nam
)
1184 and then Is_Anonymous_Access_Type
(Etype
(Expression
(Nam
)))
1185 and then not Is_Anonymous_Access_Type
(T
)
1188 ("cannot rename anonymous access object "
1189 & "as a named access type", Expression
(Nam
), T
);
1192 -- Check that a class-wide object is not being renamed as an object
1193 -- of a specific type. The test for access types is needed to exclude
1194 -- cases where the renamed object is a dynamically tagged access
1195 -- result, such as occurs in certain expansions.
1197 if Is_Tagged_Type
(T
) then
1198 Check_Dynamically_Tagged_Expression
1204 -- Ada 2005 (AI-230/AI-254): Access renaming
1206 else pragma Assert
(Present
(Access_Definition
(N
)));
1210 N
=> Access_Definition
(N
));
1214 -- The object renaming declaration may become Ghost if it renames a
1217 if Is_Entity_Name
(Nam
) then
1218 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
1221 -- Ada 2005 AI05-105: if the declaration has an anonymous access
1222 -- type, the renamed object must also have an anonymous type, and
1223 -- this is a name resolution rule. This was implicit in the last part
1224 -- of the first sentence in 8.5.1(3/2), and is made explicit by this
1227 if not Is_Overloaded
(Nam
) then
1228 if Ekind
(Etype
(Nam
)) /= Ekind
(T
) then
1230 ("expect anonymous access type in object renaming", N
);
1237 Typ
: Entity_Id
:= Empty
;
1238 Seen
: Boolean := False;
1241 Get_First_Interp
(Nam
, I
, It
);
1242 while Present
(It
.Typ
) loop
1244 -- Renaming is ambiguous if more than one candidate
1245 -- interpretation is type-conformant with the context.
1247 if Ekind
(It
.Typ
) = Ekind
(T
) then
1248 if Ekind
(T
) = E_Anonymous_Access_Subprogram_Type
1251 (Designated_Type
(T
), Designated_Type
(It
.Typ
))
1257 ("ambiguous expression in renaming", Nam
);
1260 elsif Ekind
(T
) = E_Anonymous_Access_Type
1262 Covers
(Designated_Type
(T
), Designated_Type
(It
.Typ
))
1268 ("ambiguous expression in renaming", Nam
);
1272 if Covers
(T
, It
.Typ
) then
1274 Set_Etype
(Nam
, Typ
);
1275 Set_Is_Overloaded
(Nam
, False);
1279 Get_Next_Interp
(I
, It
);
1286 -- Do not perform the legality checks below when the resolution of
1287 -- the renaming name failed because the associated type is Any_Type.
1289 if Etype
(Nam
) = Any_Type
then
1292 -- Ada 2005 (AI-231): In the case where the type is defined by an
1293 -- access_definition, the renamed entity shall be of an access-to-
1294 -- constant type if and only if the access_definition defines an
1295 -- access-to-constant type. ARM 8.5.1(4)
1297 elsif Constant_Present
(Access_Definition
(N
))
1298 and then not Is_Access_Constant
(Etype
(Nam
))
1301 ("(Ada 2005): the renamed object is not access-to-constant "
1302 & "(RM 8.5.1(6))", N
);
1304 elsif not Constant_Present
(Access_Definition
(N
))
1305 and then Is_Access_Constant
(Etype
(Nam
))
1308 ("(Ada 2005): the renamed object is not access-to-variable "
1309 & "(RM 8.5.1(6))", N
);
1312 if Is_Access_Subprogram_Type
(Etype
(Nam
)) then
1313 Check_Subtype_Conformant
1314 (Designated_Type
(T
), Designated_Type
(Etype
(Nam
)));
1316 elsif not Subtypes_Statically_Match
1317 (Designated_Type
(T
),
1318 Available_View
(Designated_Type
(Etype
(Nam
))))
1321 ("subtype of renamed object does not statically match", N
);
1325 -- Special processing for renaming function return object. Some errors
1326 -- and warnings are produced only for calls that come from source.
1328 if Nkind
(Nam
) = N_Function_Call
then
1331 -- Usage is illegal in Ada 83, but renamings are also introduced
1332 -- during expansion, and error does not apply to those.
1335 if Comes_From_Source
(N
) then
1337 ("(Ada 83) cannot rename function return object", Nam
);
1340 -- In Ada 95, warn for odd case of renaming parameterless function
1341 -- call if this is not a limited type (where this is useful).
1344 if Warn_On_Object_Renames_Function
1345 and then No
(Parameter_Associations
(Nam
))
1346 and then not Is_Limited_Type
(Etype
(Nam
))
1347 and then Comes_From_Source
(Nam
)
1350 ("renaming function result object is suspicious?.r?", Nam
);
1352 ("\function & will be called only once?.r?", Nam
,
1353 Entity
(Name
(Nam
)));
1354 Error_Msg_N
-- CODEFIX
1355 ("\suggest using an initialized constant object "
1356 & "instead?.r?", Nam
);
1361 Check_Constrained_Object
;
1363 -- An object renaming requires an exact match of the type. Class-wide
1364 -- matching is not allowed.
1366 if Is_Class_Wide_Type
(T
)
1367 and then Base_Type
(Etype
(Nam
)) /= Base_Type
(T
)
1369 Wrong_Type
(Nam
, T
);
1372 -- We must search for an actual subtype here so that the bounds of
1373 -- objects of unconstrained types don't get dropped on the floor - such
1374 -- as with renamings of formal parameters.
1376 T2
:= Get_Actual_Subtype_If_Available
(Nam
);
1378 -- Ada 2005 (AI-326): Handle wrong use of incomplete type
1380 if Nkind
(Nam
) = N_Explicit_Dereference
1381 and then Ekind
(Etype
(T2
)) = E_Incomplete_Type
1383 Error_Msg_NE
("invalid use of incomplete type&", Id
, T2
);
1386 elsif Ekind
(Etype
(T
)) = E_Incomplete_Type
then
1387 Error_Msg_NE
("invalid use of incomplete type&", Id
, T
);
1391 if Ada_Version
>= Ada_2005
and then Nkind
(Nam
) in N_Has_Entity
then
1393 Nam_Ent
: constant Entity_Id
:= Entity
(Get_Object_Name
(Nam
));
1394 Nam_Decl
: constant Node_Id
:= Declaration_Node
(Nam_Ent
);
1397 if Has_Null_Exclusion
(N
)
1398 and then not Has_Null_Exclusion
(Nam_Decl
)
1400 -- Ada 2005 (AI-423): If the object name denotes a generic
1401 -- formal object of a generic unit G, and the object renaming
1402 -- declaration occurs within the body of G or within the body
1403 -- of a generic unit declared within the declarative region
1404 -- of G, then the declaration of the formal object of G must
1405 -- have a null exclusion or a null-excluding subtype.
1407 if Is_Formal_Object
(Nam_Ent
)
1408 and then In_Generic_Scope
(Id
)
1410 if not Can_Never_Be_Null
(Etype
(Nam_Ent
)) then
1412 ("object does not exclude `NULL` "
1413 & "(RM 8.5.1(4.6/2))", N
);
1415 elsif In_Package_Body
(Scope
(Id
)) then
1417 ("formal object does not have a null exclusion"
1418 & "(RM 8.5.1(4.6/2))", N
);
1421 -- Ada 2005 (AI-423): Otherwise, the subtype of the object name
1422 -- shall exclude null.
1424 elsif not Can_Never_Be_Null
(Etype
(Nam_Ent
)) then
1426 ("object does not exclude `NULL` "
1427 & "(RM 8.5.1(4.6/2))", N
);
1429 -- An instance is illegal if it contains a renaming that
1430 -- excludes null, and the actual does not. The renaming
1431 -- declaration has already indicated that the declaration
1432 -- of the renamed actual in the instance will raise
1433 -- constraint_error.
1435 elsif Nkind
(Nam_Decl
) = N_Object_Declaration
1436 and then In_Instance
1438 Present
(Corresponding_Generic_Association
(Nam_Decl
))
1439 and then Nkind
(Expression
(Nam_Decl
)) =
1440 N_Raise_Constraint_Error
1443 ("actual does not exclude `NULL` (RM 8.5.1(4.6/2))", N
);
1445 -- Finally, if there is a null exclusion, the subtype mark
1446 -- must not be null-excluding.
1448 elsif No
(Access_Definition
(N
))
1449 and then Can_Never_Be_Null
(T
)
1452 ("`NOT NULL` not allowed (& already excludes null)",
1457 elsif Can_Never_Be_Null
(T
)
1458 and then not Can_Never_Be_Null
(Etype
(Nam_Ent
))
1461 ("object does not exclude `NULL` (RM 8.5.1(4.6/2))", N
);
1463 elsif Has_Null_Exclusion
(N
)
1464 and then No
(Access_Definition
(N
))
1465 and then Can_Never_Be_Null
(T
)
1468 ("`NOT NULL` not allowed (& already excludes null)", N
, T
);
1473 -- Set the Ekind of the entity, unless it has been set already, as is
1474 -- the case for the iteration object over a container with no variable
1475 -- indexing. In that case it's been marked as a constant, and we do not
1476 -- want to change it to a variable.
1478 if Ekind
(Id
) /= E_Constant
then
1479 Mutate_Ekind
(Id
, E_Variable
);
1482 Reinit_Object_Size_Align
(Id
);
1484 -- If N comes from source then check that the original node is an
1485 -- object reference since there may have been several rewritting and
1486 -- folding. Do not do this for N_Function_Call or N_Explicit_Dereference
1487 -- which might correspond to rewrites of e.g. N_Selected_Component
1488 -- (for example Object.Method rewriting).
1489 -- If N does not come from source then assume the tree is properly
1490 -- formed and accept any object reference. In such cases we do support
1491 -- more cases of renamings anyway, so the actual check on which renaming
1492 -- is valid is better left to the code generator as a last sanity
1495 if Comes_From_Source
(N
) then
1496 if Nkind
(Nam
) in N_Function_Call | N_Explicit_Dereference
then
1497 Is_Object_Ref
:= Is_Object_Reference
(Nam
);
1499 Is_Object_Ref
:= Is_Object_Reference
(Original_Node
(Nam
));
1502 Is_Object_Ref
:= True;
1505 if T
= Any_Type
or else Etype
(Nam
) = Any_Type
then
1508 -- Verify that the renamed entity is an object or function call
1510 elsif Is_Object_Ref
then
1511 if Comes_From_Source
(N
) then
1512 if Is_Dependent_Component_Of_Mutable_Object
(Nam
) then
1514 ("illegal renaming of discriminant-dependent component", Nam
);
1515 elsif Depends_On_Mutably_Tagged_Ext_Comp
(Nam
) then
1517 ("illegal renaming of mutably tagged dependent component",
1521 -- If the renaming comes from source and the renamed object is a
1522 -- dereference, then mark the prefix as needing debug information,
1523 -- since it might have been rewritten hence internally generated
1524 -- and Debug_Renaming_Declaration will link the renaming to it.
1526 if Nkind
(Nam
) = N_Explicit_Dereference
1527 and then Is_Entity_Name
(Prefix
(Nam
))
1529 Set_Debug_Info_Needed
(Entity
(Prefix
(Nam
)));
1533 -- Weird but legal, equivalent to renaming a function call. Illegal
1534 -- if the literal is the result of constant-folding an attribute
1535 -- reference that is not a function.
1537 elsif Is_Entity_Name
(Nam
)
1538 and then Ekind
(Entity
(Nam
)) = E_Enumeration_Literal
1539 and then Nkind
(Original_Node
(Nam
)) /= N_Attribute_Reference
1543 -- A named number can only be renamed without a subtype mark
1545 elsif Nkind
(Nam
) in N_Real_Literal | N_Integer_Literal
1546 and then Present
(Subtype_Mark
(N
))
1547 and then Present
(Original_Entity
(Nam
))
1549 Error_Msg_N
("incompatible types in renaming", Nam
);
1551 -- AI12-0383: Names that denote values can be renamed.
1552 -- Ignore (accept) N_Raise_xxx_Error nodes in this context.
1554 elsif No_Raise_xxx_Error
(Nam
) = OK
then
1555 Error_Msg_Ada_2022_Feature
("value in renaming", Sloc
(Nam
));
1560 if not Is_Variable
(Nam
) then
1561 Mutate_Ekind
(Id
, E_Constant
);
1562 Set_Never_Set_In_Source
(Id
, True);
1563 Set_Is_True_Constant
(Id
, True);
1566 -- The entity of the renaming declaration needs to reflect whether the
1567 -- renamed object is atomic, independent, volatile or VFA. These flags
1568 -- are set on the renamed object in the RM legality sense.
1570 Set_Is_Atomic
(Id
, Is_Atomic_Object
(Nam
));
1571 Set_Is_Independent
(Id
, Is_Independent_Object
(Nam
));
1572 Set_Is_Volatile
(Id
, Is_Volatile_Object_Ref
(Nam
));
1573 Set_Is_Volatile_Full_Access
1574 (Id
, Is_Volatile_Full_Access_Object_Ref
(Nam
));
1576 -- Treat as volatile if we just set the Volatile flag
1580 -- Or if we are renaming an entity which was marked this way
1582 -- Are there more cases, e.g. X(J) where X is Treat_As_Volatile ???
1584 or else (Is_Entity_Name
(Nam
)
1585 and then Treat_As_Volatile
(Entity
(Nam
)))
1587 Set_Treat_As_Volatile
(Id
, True);
1590 -- Now make the link to the renamed object
1592 Set_Renamed_Object
(Id
, Nam
);
1594 -- Implementation-defined aspect specifications can appear in a renaming
1595 -- declaration, but not language-defined ones. The call to procedure
1596 -- Analyze_Aspect_Specifications will take care of this error check.
1598 Analyze_Aspect_Specifications
(N
, Id
);
1600 -- Deal with dimensions
1602 Analyze_Dimension
(N
);
1603 end Analyze_Object_Renaming
;
1605 ------------------------------
1606 -- Analyze_Package_Renaming --
1607 ------------------------------
1609 procedure Analyze_Package_Renaming
(N
: Node_Id
) is
1610 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
1615 if Name
(N
) = Error
then
1619 -- Check for Text_IO special units (we may be renaming a Text_IO child),
1620 -- but make sure not to catch renamings generated for package instances
1621 -- that have nothing to do with them but are nevertheless homonyms.
1623 if Is_Entity_Name
(Name
(N
))
1624 and then Present
(Entity
(Name
(N
)))
1625 and then Is_Generic_Instance
(Entity
(Name
(N
)))
1629 Check_Text_IO_Special_Unit
(Name
(N
));
1632 if Current_Scope
/= Standard_Standard
then
1633 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
1639 if Is_Entity_Name
(Name
(N
)) then
1640 Old_P
:= Entity
(Name
(N
));
1645 if Etype
(Old_P
) = Any_Type
then
1646 Error_Msg_N
("expect package name in renaming", Name
(N
));
1648 elsif Ekind
(Old_P
) /= E_Package
1649 and then not (Ekind
(Old_P
) = E_Generic_Package
1650 and then In_Open_Scopes
(Old_P
))
1652 if Ekind
(Old_P
) = E_Generic_Package
then
1654 ("generic package cannot be renamed as a package", Name
(N
));
1656 Error_Msg_Sloc
:= Sloc
(Old_P
);
1658 ("expect package name in renaming, found& declared#",
1662 -- Set basic attributes to minimize cascaded errors
1664 Mutate_Ekind
(New_P
, E_Package
);
1665 Set_Etype
(New_P
, Standard_Void_Type
);
1667 elsif Present
(Renamed_Entity
(Old_P
))
1668 and then (From_Limited_With
(Renamed_Entity
(Old_P
))
1669 or else Has_Limited_View
(Renamed_Entity
(Old_P
)))
1671 Unit_Is_Visible
(Cunit
(Get_Source_Unit
(Renamed_Entity
(Old_P
))))
1674 ("renaming of limited view of package & not usable in this context"
1675 & " (RM 8.5.3(3.1/2))", Name
(N
), Renamed_Entity
(Old_P
));
1677 -- Set basic attributes to minimize cascaded errors
1679 Mutate_Ekind
(New_P
, E_Package
);
1680 Set_Etype
(New_P
, Standard_Void_Type
);
1682 -- Here for OK package renaming
1685 -- Entities in the old package are accessible through the renaming
1686 -- entity. The simplest implementation is to have both packages share
1689 Mutate_Ekind
(New_P
, E_Package
);
1690 Set_Etype
(New_P
, Standard_Void_Type
);
1692 if Present
(Renamed_Entity
(Old_P
)) then
1693 Set_Renamed_Entity
(New_P
, Renamed_Entity
(Old_P
));
1695 Set_Renamed_Entity
(New_P
, Old_P
);
1698 -- The package renaming declaration may become Ghost if it renames a
1701 Mark_Ghost_Renaming
(N
, Old_P
);
1703 Set_Has_Completion
(New_P
);
1704 Set_First_Entity
(New_P
, First_Entity
(Old_P
));
1705 Set_Last_Entity
(New_P
, Last_Entity
(Old_P
));
1706 Set_First_Private_Entity
(New_P
, First_Private_Entity
(Old_P
));
1707 Check_Library_Unit_Renaming
(N
, Old_P
);
1708 Generate_Reference
(Old_P
, Name
(N
));
1710 -- If the renaming is in the visible part of a package, then we set
1711 -- Renamed_In_Spec for the renamed package, to prevent giving
1712 -- warnings about no entities referenced. Such a warning would be
1713 -- overenthusiastic, since clients can see entities in the renamed
1714 -- package via the visible package renaming.
1717 Ent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
1719 if Ekind
(Ent
) = E_Package
1720 and then not In_Private_Part
(Ent
)
1721 and then In_Extended_Main_Source_Unit
(N
)
1722 and then Ekind
(Old_P
) = E_Package
1724 Set_Renamed_In_Spec
(Old_P
);
1728 -- If this is the renaming declaration of a package instantiation
1729 -- within itself, it is the declaration that ends the list of actuals
1730 -- for the instantiation. At this point, the subtypes that rename
1731 -- the actuals are flagged as generic, to avoid spurious ambiguities
1732 -- if the actuals for two distinct formals happen to coincide. If
1733 -- the actual is a private type, the subtype has a private completion
1734 -- that is flagged in the same fashion.
1736 -- Resolution is identical to what is was in the original generic.
1737 -- On exit from the generic instance, these are turned into regular
1738 -- subtypes again, so they are compatible with types in their class.
1740 if not Is_Generic_Instance
(Old_P
) then
1743 Spec
:= Specification
(Unit_Declaration_Node
(Old_P
));
1746 if Nkind
(Spec
) = N_Package_Specification
1747 and then Present
(Generic_Parent
(Spec
))
1748 and then Old_P
= Current_Scope
1749 and then Chars
(New_P
) = Chars
(Generic_Parent
(Spec
))
1755 E
:= First_Entity
(Old_P
);
1756 while Present
(E
) and then E
/= New_P
loop
1758 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
1760 Set_Is_Generic_Actual_Type
(E
);
1762 if Is_Private_Type
(E
)
1763 and then Present
(Full_View
(E
))
1765 Set_Is_Generic_Actual_Type
(Full_View
(E
));
1775 -- Implementation-defined aspect specifications can appear in a renaming
1776 -- declaration, but not language-defined ones. The call to procedure
1777 -- Analyze_Aspect_Specifications will take care of this error check.
1779 Analyze_Aspect_Specifications
(N
, New_P
);
1780 end Analyze_Package_Renaming
;
1782 -------------------------------
1783 -- Analyze_Renamed_Character --
1784 -------------------------------
1786 procedure Analyze_Renamed_Character
1791 C
: constant Node_Id
:= Name
(N
);
1794 if Ekind
(New_S
) = E_Function
then
1795 Resolve
(C
, Etype
(New_S
));
1798 Check_Frozen_Renaming
(N
, New_S
);
1802 Error_Msg_N
("character literal can only be renamed as function", N
);
1804 end Analyze_Renamed_Character
;
1806 ---------------------------------
1807 -- Analyze_Renamed_Dereference --
1808 ---------------------------------
1810 procedure Analyze_Renamed_Dereference
1815 Nam
: constant Node_Id
:= Name
(N
);
1816 P
: constant Node_Id
:= Prefix
(Nam
);
1822 if not Is_Overloaded
(P
) then
1823 if Ekind
(Etype
(Nam
)) /= E_Subprogram_Type
1824 or else not Type_Conformant
(Etype
(Nam
), New_S
)
1826 Error_Msg_N
("designated type does not match specification", P
);
1835 Get_First_Interp
(Nam
, Ind
, It
);
1837 while Present
(It
.Nam
) loop
1839 if Ekind
(It
.Nam
) = E_Subprogram_Type
1840 and then Type_Conformant
(It
.Nam
, New_S
)
1842 if Typ
/= Any_Id
then
1843 Error_Msg_N
("ambiguous renaming", P
);
1850 Get_Next_Interp
(Ind
, It
);
1853 if Typ
= Any_Type
then
1854 Error_Msg_N
("designated type does not match specification", P
);
1859 Check_Frozen_Renaming
(N
, New_S
);
1863 end Analyze_Renamed_Dereference
;
1865 ---------------------------
1866 -- Analyze_Renamed_Entry --
1867 ---------------------------
1869 procedure Analyze_Renamed_Entry
1874 Nam
: constant Node_Id
:= Name
(N
);
1875 Sel
: constant Node_Id
:= Selector_Name
(Nam
);
1876 Is_Actual
: constant Boolean := Present
(Corresponding_Formal_Spec
(N
));
1880 if Entity
(Sel
) = Any_Id
then
1882 -- Selector is undefined on prefix. Error emitted already
1884 Set_Has_Completion
(New_S
);
1888 -- Otherwise find renamed entity and build body of New_S as a call to it
1890 Old_S
:= Find_Renamed_Entity
(N
, Selector_Name
(Nam
), New_S
);
1892 if Old_S
= Any_Id
then
1893 Error_Msg_N
("no subprogram or entry matches specification", N
);
1896 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1897 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1898 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1901 -- Only mode conformance required for a renaming_as_declaration
1903 Check_Mode_Conformant
(New_S
, Old_S
, N
);
1906 Inherit_Renamed_Profile
(New_S
, Old_S
);
1908 -- The prefix can be an arbitrary expression that yields a task or
1909 -- protected object, so it must be resolved.
1911 if Is_Access_Type
(Etype
(Prefix
(Nam
))) then
1912 Insert_Explicit_Dereference
(Prefix
(Nam
));
1914 Resolve
(Prefix
(Nam
), Scope
(Old_S
));
1917 Set_Convention
(New_S
, Convention
(Old_S
));
1918 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1920 -- AI05-0225: If the renamed entity is a procedure or entry of a
1921 -- protected object, the target object must be a variable.
1923 if Is_Protected_Type
(Scope
(Old_S
))
1924 and then Ekind
(New_S
) = E_Procedure
1925 and then not Is_Variable
(Prefix
(Nam
))
1929 ("target object of protected operation used as actual for "
1930 & "formal procedure must be a variable", Nam
);
1933 ("target object of protected operation renamed as procedure, "
1934 & "must be a variable", Nam
);
1939 Check_Frozen_Renaming
(N
, New_S
);
1941 end Analyze_Renamed_Entry
;
1943 -----------------------------------
1944 -- Analyze_Renamed_Family_Member --
1945 -----------------------------------
1947 procedure Analyze_Renamed_Family_Member
1952 Nam
: constant Node_Id
:= Name
(N
);
1953 P
: constant Node_Id
:= Prefix
(Nam
);
1957 if (Is_Entity_Name
(P
) and then Ekind
(Entity
(P
)) = E_Entry_Family
)
1958 or else (Nkind
(P
) = N_Selected_Component
1959 and then Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
)
1961 if Is_Entity_Name
(P
) then
1962 Old_S
:= Entity
(P
);
1964 Old_S
:= Entity
(Selector_Name
(P
));
1967 if not Entity_Matches_Spec
(Old_S
, New_S
) then
1968 Error_Msg_N
("entry family does not match specification", N
);
1971 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1972 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1973 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1977 Error_Msg_N
("no entry family matches specification", N
);
1980 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1983 Check_Frozen_Renaming
(N
, New_S
);
1985 end Analyze_Renamed_Family_Member
;
1987 -----------------------------------------
1988 -- Analyze_Renamed_Primitive_Operation --
1989 -----------------------------------------
1991 procedure Analyze_Renamed_Primitive_Operation
2001 Ctyp
: Conformance_Type
) return Boolean;
2002 -- Verify that the signatures of the renamed entity and the new entity
2003 -- match. The first formal of the renamed entity is skipped because it
2004 -- is the target object in any subsequent call.
2012 Ctyp
: Conformance_Type
) return Boolean
2018 if Ekind
(Subp
) /= Ekind
(New_S
) then
2022 Old_F
:= Next_Formal
(First_Formal
(Subp
));
2023 New_F
:= First_Formal
(New_S
);
2024 while Present
(Old_F
) and then Present
(New_F
) loop
2025 if not Conforming_Types
(Etype
(Old_F
), Etype
(New_F
), Ctyp
) then
2029 if Ctyp
>= Mode_Conformant
2030 and then Ekind
(Old_F
) /= Ekind
(New_F
)
2035 Next_Formal
(New_F
);
2036 Next_Formal
(Old_F
);
2042 -- Start of processing for Analyze_Renamed_Primitive_Operation
2045 if not Is_Overloaded
(Selector_Name
(Name
(N
))) then
2046 Old_S
:= Entity
(Selector_Name
(Name
(N
)));
2048 if not Conforms
(Old_S
, Type_Conformant
) then
2053 -- Find the operation that matches the given signature
2061 Get_First_Interp
(Selector_Name
(Name
(N
)), Ind
, It
);
2063 while Present
(It
.Nam
) loop
2064 if Conforms
(It
.Nam
, Type_Conformant
) then
2068 Get_Next_Interp
(Ind
, It
);
2073 if Old_S
= Any_Id
then
2074 Error_Msg_N
("no subprogram or entry matches specification", N
);
2078 if not Conforms
(Old_S
, Subtype_Conformant
) then
2079 Error_Msg_N
("subtype conformance error in renaming", N
);
2082 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
2083 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
2086 -- Only mode conformance required for a renaming_as_declaration
2088 if not Conforms
(Old_S
, Mode_Conformant
) then
2089 Error_Msg_N
("mode conformance error in renaming", N
);
2092 -- AI12-0204: The prefix of a prefixed view that is renamed or
2093 -- passed as a formal subprogram must be renamable as an object.
2095 Nam
:= Prefix
(Name
(N
));
2097 if Is_Object_Reference
(Nam
) then
2098 if Is_Dependent_Component_Of_Mutable_Object
(Nam
) then
2100 ("illegal renaming of discriminant-dependent component",
2102 elsif Depends_On_Mutably_Tagged_Ext_Comp
(Nam
) then
2104 ("illegal renaming of mutably tagged dependent component",
2108 Error_Msg_N
("expect object name in renaming", Nam
);
2111 -- Enforce the rule given in (RM 6.3.1 (10.1/2)): a prefixed
2112 -- view of a subprogram is intrinsic, because the compiler has
2113 -- to generate a wrapper for any call to it. If the name in a
2114 -- subprogram renaming is a prefixed view, the entity is thus
2115 -- intrinsic, and 'Access cannot be applied to it.
2117 Set_Convention
(New_S
, Convention_Intrinsic
);
2120 -- Inherit_Renamed_Profile (New_S, Old_S);
2122 -- The prefix can be an arbitrary expression that yields an
2123 -- object, so it must be resolved.
2125 Resolve
(Prefix
(Name
(N
)));
2127 end Analyze_Renamed_Primitive_Operation
;
2129 ---------------------------------
2130 -- Analyze_Subprogram_Renaming --
2131 ---------------------------------
2133 procedure Analyze_Subprogram_Renaming
(N
: Node_Id
) is
2134 Formal_Spec
: constant Entity_Id
:= Corresponding_Formal_Spec
(N
);
2135 Is_Actual
: constant Boolean := Present
(Formal_Spec
);
2136 Nam
: constant Node_Id
:= Name
(N
);
2137 Save_AV
: constant Ada_Version_Type
:= Ada_Version
;
2138 Save_AVP
: constant Node_Id
:= Ada_Version_Pragma
;
2139 Save_AV_Exp
: constant Ada_Version_Type
:= Ada_Version_Explicit
;
2140 Spec
: constant Node_Id
:= Specification
(N
);
2142 Old_S
: Entity_Id
:= Empty
;
2143 Rename_Spec
: Entity_Id
;
2145 procedure Check_Null_Exclusion
2148 -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the
2149 -- following AI rules:
2151 -- If Ren denotes a generic formal object of a generic unit G, and the
2152 -- renaming (or instantiation containing the actual) occurs within the
2153 -- body of G or within the body of a generic unit declared within the
2154 -- declarative region of G, then the corresponding parameter of G
2155 -- shall have a null_exclusion; Otherwise the subtype of the Sub's
2156 -- formal parameter shall exclude null.
2158 -- Similarly for its return profile.
2160 procedure Check_SPARK_Primitive_Operation
(Subp_Id
: Entity_Id
);
2161 -- Ensure that a SPARK renaming denoted by its entity Subp_Id does not
2162 -- declare a primitive operation of a tagged type (SPARK RM 6.1.1(3)).
2164 procedure Freeze_Actual_Profile
;
2165 -- In Ada 2012, enforce the freezing rule concerning formal incomplete
2166 -- types: a callable entity freezes its profile, unless it has an
2167 -- incomplete untagged formal (RM 13.14(10.2/3)).
2169 function Has_Class_Wide_Actual
return Boolean;
2170 -- Ada 2012 (AI05-071, AI05-0131) and Ada 2022 (AI12-0165): True if N is
2171 -- the renaming for a defaulted formal subprogram where the actual for
2172 -- the controlling formal type is class-wide.
2174 procedure Handle_Instance_With_Class_Wide_Type
2175 (Inst_Node
: Node_Id
;
2177 Wrapped_Prim
: out Entity_Id
;
2178 Wrap_Id
: out Entity_Id
);
2179 -- Ada 2012 (AI05-0071), Ada 2022 (AI12-0165): when the actual type
2180 -- of an instantiation is a class-wide type T'Class we may need to
2181 -- wrap a primitive operation of T; this routine looks for a suitable
2182 -- primitive to be wrapped and (if the wrapper is required) returns the
2183 -- Id of the wrapped primitive and the Id of the built wrapper. Ren_Id
2184 -- is the defining entity for the renamed subprogram specification.
2186 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
;
2187 -- Find renamed entity when the declaration is a renaming_as_body and
2188 -- the renamed entity may itself be a renaming_as_body. Used to enforce
2189 -- rule that a renaming_as_body is illegal if the declaration occurs
2190 -- before the subprogram it completes is frozen, and renaming indirectly
2191 -- renames the subprogram itself.(Defect Report 8652/0027).
2193 --------------------------
2194 -- Check_Null_Exclusion --
2195 --------------------------
2197 procedure Check_Null_Exclusion
2201 Ren_Formal
: Entity_Id
;
2202 Sub_Formal
: Entity_Id
;
2204 function Null_Exclusion_Mismatch
2205 (Renaming
: Entity_Id
; Renamed
: Entity_Id
) return Boolean;
2206 -- Return True if there is a null exclusion mismatch between
2207 -- Renaming and Renamed, False otherwise.
2209 -----------------------------
2210 -- Null_Exclusion_Mismatch --
2211 -----------------------------
2213 function Null_Exclusion_Mismatch
2214 (Renaming
: Entity_Id
; Renamed
: Entity_Id
) return Boolean is
2216 return Has_Null_Exclusion
(Parent
(Renaming
))
2218 not (Has_Null_Exclusion
(Parent
(Renamed
))
2219 or else (Can_Never_Be_Null
(Etype
(Renamed
))
2221 (Is_Formal_Subprogram
(Sub
)
2222 and then In_Generic_Body
(Current_Scope
))));
2223 end Null_Exclusion_Mismatch
;
2228 Ren_Formal
:= First_Formal
(Ren
);
2229 Sub_Formal
:= First_Formal
(Sub
);
2230 while Present
(Ren_Formal
) and then Present
(Sub_Formal
) loop
2231 if Null_Exclusion_Mismatch
(Ren_Formal
, Sub_Formal
) then
2232 Error_Msg_Sloc
:= Sloc
(Sub_Formal
);
2234 ("`NOT NULL` required for parameter &#",
2235 Ren_Formal
, Sub_Formal
);
2238 Next_Formal
(Ren_Formal
);
2239 Next_Formal
(Sub_Formal
);
2242 -- Return profile check
2244 if Nkind
(Parent
(Ren
)) = N_Function_Specification
2245 and then Nkind
(Parent
(Sub
)) = N_Function_Specification
2246 and then Null_Exclusion_Mismatch
(Ren
, Sub
)
2248 Error_Msg_Sloc
:= Sloc
(Sub
);
2249 Error_Msg_N
("return must specify `NOT NULL`#", Ren
);
2251 end Check_Null_Exclusion
;
2253 -------------------------------------
2254 -- Check_SPARK_Primitive_Operation --
2255 -------------------------------------
2257 procedure Check_SPARK_Primitive_Operation
(Subp_Id
: Entity_Id
) is
2258 Prag
: constant Node_Id
:= SPARK_Pragma
(Subp_Id
);
2262 -- Nothing to do when the subprogram is not subject to SPARK_Mode On
2263 -- because this check applies to SPARK code only.
2265 if not (Present
(Prag
)
2266 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
)
2270 -- Nothing to do when the subprogram is not a primitive operation
2272 elsif not Is_Primitive
(Subp_Id
) then
2276 Typ
:= Find_Dispatching_Type
(Subp_Id
);
2278 -- Nothing to do when the subprogram is a primitive operation of an
2285 -- At this point a renaming declaration introduces a new primitive
2286 -- operation for a tagged type.
2288 Error_Msg_Node_2
:= Typ
;
2290 ("subprogram renaming & cannot declare primitive for type & "
2291 & "(SPARK RM 6.1.1(3))", N
, Subp_Id
);
2292 end Check_SPARK_Primitive_Operation
;
2294 ---------------------------
2295 -- Freeze_Actual_Profile --
2296 ---------------------------
2298 procedure Freeze_Actual_Profile
is
2300 Has_Untagged_Inc
: Boolean;
2301 Instantiation_Node
: constant Node_Id
:= Parent
(N
);
2304 if Ada_Version
>= Ada_2012
then
2305 F
:= First_Formal
(Formal_Spec
);
2306 Has_Untagged_Inc
:= False;
2307 while Present
(F
) loop
2308 if Ekind
(Etype
(F
)) = E_Incomplete_Type
2309 and then not Is_Tagged_Type
(Etype
(F
))
2311 Has_Untagged_Inc
:= True;
2318 if Ekind
(Formal_Spec
) = E_Function
2319 and then not Is_Tagged_Type
(Etype
(Formal_Spec
))
2321 Has_Untagged_Inc
:= True;
2324 if not Has_Untagged_Inc
then
2325 F
:= First_Formal
(Old_S
);
2326 while Present
(F
) loop
2327 Freeze_Before
(Instantiation_Node
, Etype
(F
));
2329 if Is_Incomplete_Or_Private_Type
(Etype
(F
))
2330 and then No
(Underlying_Type
(Etype
(F
)))
2332 -- Exclude generic types, or types derived from them.
2333 -- They will be frozen in the enclosing instance.
2335 if Is_Generic_Type
(Etype
(F
))
2336 or else Is_Generic_Type
(Root_Type
(Etype
(F
)))
2340 -- A limited view of a type declared elsewhere needs no
2341 -- freezing actions.
2343 elsif From_Limited_With
(Etype
(F
)) then
2348 ("type& must be frozen before this point",
2349 Instantiation_Node
, Etype
(F
));
2357 end Freeze_Actual_Profile
;
2359 ---------------------------
2360 -- Has_Class_Wide_Actual --
2361 ---------------------------
2363 function Has_Class_Wide_Actual
return Boolean is
2365 Formal_Typ
: Entity_Id
;
2369 Formal
:= First_Formal
(Formal_Spec
);
2370 while Present
(Formal
) loop
2371 Formal_Typ
:= Etype
(Formal
);
2373 if Has_Unknown_Discriminants
(Formal_Typ
)
2374 and then not Is_Class_Wide_Type
(Formal_Typ
)
2375 and then Is_Class_Wide_Type
(Get_Instance_Of
(Formal_Typ
))
2380 Next_Formal
(Formal
);
2385 end Has_Class_Wide_Actual
;
2387 ------------------------------------------
2388 -- Handle_Instance_With_Class_Wide_Type --
2389 ------------------------------------------
2391 procedure Handle_Instance_With_Class_Wide_Type
2392 (Inst_Node
: Node_Id
;
2394 Wrapped_Prim
: out Entity_Id
;
2395 Wrap_Id
: out Entity_Id
)
2397 procedure Build_Class_Wide_Wrapper
2398 (Ren_Id
: Entity_Id
;
2399 Prim_Op
: Entity_Id
;
2400 Wrap_Id
: out Entity_Id
);
2401 -- Build a wrapper for the renaming Ren_Id of subprogram Prim_Op.
2403 procedure Find_Suitable_Candidate
2404 (Prim_Op
: out Entity_Id
;
2405 Is_CW_Prim
: out Boolean);
2406 -- Look for a suitable primitive to be wrapped (Prim_Op); Is_CW_Prim
2407 -- indicates that the found candidate is a class-wide primitive (to
2408 -- help the caller decide if the wrapper is required).
2410 ------------------------------
2411 -- Build_Class_Wide_Wrapper --
2412 ------------------------------
2414 procedure Build_Class_Wide_Wrapper
2415 (Ren_Id
: Entity_Id
;
2416 Prim_Op
: Entity_Id
;
2417 Wrap_Id
: out Entity_Id
)
2419 Loc
: constant Source_Ptr
:= Sloc
(N
);
2422 (Subp_Id
: Entity_Id
;
2423 Params
: List_Id
) return Node_Id
;
2424 -- Create a dispatching call to invoke routine Subp_Id with
2425 -- actuals built from the parameter specifications of list Params.
2427 function Build_Expr_Fun_Call
2428 (Subp_Id
: Entity_Id
;
2429 Params
: List_Id
) return Node_Id
;
2430 -- Create a dispatching call to invoke function Subp_Id with
2431 -- actuals built from the parameter specifications of list Params.
2432 -- Directly return the call, so that it can be used inside an
2433 -- expression function. This is a requirement of GNATprove mode.
2435 function Build_Spec
(Subp_Id
: Entity_Id
) return Node_Id
;
2436 -- Create a subprogram specification based on the subprogram
2437 -- profile of Subp_Id.
2444 (Subp_Id
: Entity_Id
;
2445 Params
: List_Id
) return Node_Id
2447 Actuals
: constant List_Id
:= New_List
;
2448 Call_Ref
: constant Node_Id
:= New_Occurrence_Of
(Subp_Id
, Loc
);
2452 -- Build the actual parameters of the call
2454 Formal
:= First
(Params
);
2455 while Present
(Formal
) loop
2457 Make_Identifier
(Loc
,
2458 Chars
(Defining_Identifier
(Formal
))));
2463 -- return Subp_Id (Actuals);
2465 if Ekind
(Subp_Id
) in E_Function | E_Operator
then
2467 Make_Simple_Return_Statement
(Loc
,
2469 Make_Function_Call
(Loc
,
2471 Parameter_Associations
=> Actuals
));
2474 -- Subp_Id (Actuals);
2478 Make_Procedure_Call_Statement
(Loc
,
2480 Parameter_Associations
=> Actuals
);
2484 -------------------------
2485 -- Build_Expr_Fun_Call --
2486 -------------------------
2488 function Build_Expr_Fun_Call
2489 (Subp_Id
: Entity_Id
;
2490 Params
: List_Id
) return Node_Id
2492 Actuals
: constant List_Id
:= New_List
;
2493 Call_Ref
: constant Node_Id
:= New_Occurrence_Of
(Subp_Id
, Loc
);
2497 pragma Assert
(Ekind
(Subp_Id
) in E_Function | E_Operator
);
2499 -- Build the actual parameters of the call
2501 Formal
:= First
(Params
);
2502 while Present
(Formal
) loop
2504 Make_Identifier
(Loc
,
2505 Chars
(Defining_Identifier
(Formal
))));
2510 -- Subp_Id (Actuals);
2513 Make_Function_Call
(Loc
,
2515 Parameter_Associations
=> Actuals
);
2516 end Build_Expr_Fun_Call
;
2522 function Build_Spec
(Subp_Id
: Entity_Id
) return Node_Id
is
2523 Params
: constant List_Id
:= Copy_Parameter_List
(Subp_Id
);
2524 Spec_Id
: constant Entity_Id
:=
2525 Make_Defining_Identifier
(Loc
,
2526 New_External_Name
(Chars
(Subp_Id
), 'R'));
2529 if Ekind
(Formal_Spec
) = E_Procedure
then
2531 Make_Procedure_Specification
(Loc
,
2532 Defining_Unit_Name
=> Spec_Id
,
2533 Parameter_Specifications
=> Params
);
2536 Make_Function_Specification
(Loc
,
2537 Defining_Unit_Name
=> Spec_Id
,
2538 Parameter_Specifications
=> Params
,
2539 Result_Definition
=>
2540 New_Copy_Tree
(Result_Definition
(Spec
)));
2546 Body_Decl
: Node_Id
;
2547 Spec_Decl
: Node_Id
;
2550 -- Start of processing for Build_Class_Wide_Wrapper
2553 pragma Assert
(not Error_Posted
(Nam
));
2555 -- Step 1: Create the declaration and the body of the wrapper,
2556 -- insert all the pieces into the tree.
2558 -- In GNATprove mode, create a function wrapper in the form of an
2559 -- expression function, so that an implicit postcondition relating
2560 -- the result of calling the wrapper function and the result of
2561 -- the dispatching call to the wrapped function is known during
2565 and then Ekind
(Ren_Id
) in E_Function | E_Operator
2567 New_Spec
:= Build_Spec
(Ren_Id
);
2569 Make_Expression_Function
(Loc
,
2570 Specification
=> New_Spec
,
2573 (Subp_Id
=> Prim_Op
,
2574 Params
=> Parameter_Specifications
(New_Spec
)));
2576 Wrap_Id
:= Defining_Entity
(Body_Decl
);
2578 -- Otherwise, create separate spec and body for the subprogram
2582 Make_Subprogram_Declaration
(Loc
,
2583 Specification
=> Build_Spec
(Ren_Id
));
2584 Insert_Before_And_Analyze
(N
, Spec_Decl
);
2586 Wrap_Id
:= Defining_Entity
(Spec_Decl
);
2589 Make_Subprogram_Body
(Loc
,
2590 Specification
=> Build_Spec
(Ren_Id
),
2591 Declarations
=> New_List
,
2592 Handled_Statement_Sequence
=>
2593 Make_Handled_Sequence_Of_Statements
(Loc
,
2594 Statements
=> New_List
(
2596 (Subp_Id
=> Prim_Op
,
2598 Parameter_Specifications
2599 (Specification
(Spec_Decl
))))));
2601 Set_Corresponding_Body
(Spec_Decl
, Defining_Entity
(Body_Decl
));
2604 Set_Is_Class_Wide_Wrapper
(Wrap_Id
);
2606 -- If the operator carries an Eliminated pragma, indicate that
2607 -- the wrapper is also to be eliminated, to prevent spurious
2608 -- errors when using gnatelim on programs that include box-
2609 -- defaulted initialization of equality operators.
2611 Set_Is_Eliminated
(Wrap_Id
, Is_Eliminated
(Prim_Op
));
2613 -- In GNATprove mode, insert the body in the tree for analysis
2615 if GNATprove_Mode
then
2616 Insert_Before_And_Analyze
(N
, Body_Decl
);
2619 -- The generated body does not freeze and must be analyzed when
2620 -- the class-wide wrapper is frozen. The body is only needed if
2621 -- expansion is enabled.
2623 if Expander_Active
then
2624 Append_Freeze_Action
(Wrap_Id
, Body_Decl
);
2627 -- Step 2: The subprogram renaming aliases the wrapper
2629 Rewrite
(Name
(N
), New_Occurrence_Of
(Wrap_Id
, Loc
));
2630 end Build_Class_Wide_Wrapper
;
2632 -----------------------------
2633 -- Find_Suitable_Candidate --
2634 -----------------------------
2636 procedure Find_Suitable_Candidate
2637 (Prim_Op
: out Entity_Id
;
2638 Is_CW_Prim
: out Boolean)
2640 Loc
: constant Source_Ptr
:= Sloc
(N
);
2642 function Find_Primitive
(Typ
: Entity_Id
) return Entity_Id
;
2643 -- Find a primitive subprogram of type Typ which matches the
2644 -- profile of the renaming declaration.
2646 procedure Interpretation_Error
(Subp_Id
: Entity_Id
);
2647 -- Emit a continuation error message suggesting subprogram Subp_Id
2648 -- as a possible interpretation.
2650 function Is_Intrinsic_Equality
2651 (Subp_Id
: Entity_Id
) return Boolean;
2652 -- Determine whether subprogram Subp_Id denotes the intrinsic "="
2655 function Is_Suitable_Candidate
2656 (Subp_Id
: Entity_Id
) return Boolean;
2657 -- Determine whether subprogram Subp_Id is a suitable candidate
2658 -- for the role of a wrapped subprogram.
2660 --------------------
2661 -- Find_Primitive --
2662 --------------------
2664 function Find_Primitive
(Typ
: Entity_Id
) return Entity_Id
is
2665 procedure Replace_Parameter_Types
(Spec
: Node_Id
);
2666 -- Given a specification Spec, replace all class-wide parameter
2667 -- types with reference to type Typ.
2669 -----------------------------
2670 -- Replace_Parameter_Types --
2671 -----------------------------
2673 procedure Replace_Parameter_Types
(Spec
: Node_Id
) is
2675 Formal_Id
: Entity_Id
;
2676 Formal_Typ
: Node_Id
;
2679 Formal
:= First
(Parameter_Specifications
(Spec
));
2680 while Present
(Formal
) loop
2681 Formal_Id
:= Defining_Identifier
(Formal
);
2682 Formal_Typ
:= Parameter_Type
(Formal
);
2684 -- Create a new entity for each class-wide formal to
2685 -- prevent aliasing with the original renaming. Replace
2686 -- the type of such a parameter with the candidate type.
2688 if Nkind
(Formal_Typ
) = N_Identifier
2689 and then Is_Class_Wide_Type
(Etype
(Formal_Typ
))
2691 Set_Defining_Identifier
(Formal
,
2692 Make_Defining_Identifier
(Loc
, Chars
(Formal_Id
)));
2694 Set_Parameter_Type
(Formal
,
2695 New_Occurrence_Of
(Typ
, Loc
));
2700 end Replace_Parameter_Types
;
2704 Alt_Ren
: constant Node_Id
:= New_Copy_Tree
(N
);
2705 Alt_Nam
: constant Node_Id
:= Name
(Alt_Ren
);
2706 Alt_Spec
: constant Node_Id
:= Specification
(Alt_Ren
);
2707 Subp_Id
: Entity_Id
;
2709 -- Start of processing for Find_Primitive
2712 -- Each attempt to find a suitable primitive of a particular
2713 -- type operates on its own copy of the original renaming.
2714 -- As a result the original renaming is kept decoration and
2715 -- side-effect free.
2717 -- Inherit the overloaded status of the renamed subprogram name
2719 if Is_Overloaded
(Nam
) then
2720 Set_Is_Overloaded
(Alt_Nam
);
2721 Save_Interps
(Nam
, Alt_Nam
);
2724 -- The copied renaming is hidden from visibility to prevent the
2725 -- pollution of the enclosing context.
2727 Set_Defining_Unit_Name
(Alt_Spec
, Make_Temporary
(Loc
, 'R'));
2729 -- The types of all class-wide parameters must be changed to
2730 -- the candidate type.
2732 Replace_Parameter_Types
(Alt_Spec
);
2734 -- Try to find a suitable primitive that matches the altered
2735 -- profile of the renaming specification.
2740 Nam
=> Name
(Alt_Ren
),
2741 New_S
=> Analyze_Subprogram_Specification
(Alt_Spec
),
2742 Is_Actual
=> Is_Actual
);
2744 -- Do not return Any_Id if the resolution of the altered
2745 -- profile failed as this complicates further checks on
2746 -- the caller side; return Empty instead.
2748 if Subp_Id
= Any_Id
then
2755 --------------------------
2756 -- Interpretation_Error --
2757 --------------------------
2759 procedure Interpretation_Error
(Subp_Id
: Entity_Id
) is
2761 Error_Msg_Sloc
:= Sloc
(Subp_Id
);
2763 if Is_Internal
(Subp_Id
) then
2765 ("\\possible interpretation: predefined & #",
2769 ("\\possible interpretation: & defined #",
2772 end Interpretation_Error
;
2774 ---------------------------
2775 -- Is_Intrinsic_Equality --
2776 ---------------------------
2778 function Is_Intrinsic_Equality
(Subp_Id
: Entity_Id
) return Boolean
2782 Ekind
(Subp_Id
) = E_Operator
2783 and then Chars
(Subp_Id
) = Name_Op_Eq
2784 and then Is_Intrinsic_Subprogram
(Subp_Id
);
2785 end Is_Intrinsic_Equality
;
2787 ---------------------------
2788 -- Is_Suitable_Candidate --
2789 ---------------------------
2791 function Is_Suitable_Candidate
(Subp_Id
: Entity_Id
) return Boolean
2794 if No
(Subp_Id
) then
2797 -- An intrinsic subprogram is never a good candidate. This
2798 -- is an indication of a missing primitive, either defined
2799 -- directly or inherited from a parent tagged type.
2801 elsif Is_Intrinsic_Subprogram
(Subp_Id
) then
2807 end Is_Suitable_Candidate
;
2811 Actual_Typ
: Entity_Id
:= Empty
;
2812 -- The actual class-wide type for Formal_Typ
2814 CW_Prim_OK
: Boolean;
2815 CW_Prim_Op
: Entity_Id
;
2816 -- The class-wide subprogram (if available) that corresponds to
2817 -- the renamed generic formal subprogram.
2819 Formal_Typ
: Entity_Id
:= Empty
;
2820 -- The generic formal type with unknown discriminants
2822 Root_Prim_OK
: Boolean;
2823 Root_Prim_Op
: Entity_Id
;
2824 -- The root type primitive (if available) that corresponds to the
2825 -- renamed generic formal subprogram.
2827 Root_Typ
: Entity_Id
:= Empty
;
2828 -- The root type of Actual_Typ
2832 -- Start of processing for Find_Suitable_Candidate
2835 pragma Assert
(not Error_Posted
(Nam
));
2838 Is_CW_Prim
:= False;
2840 -- Analyze the renamed name, but do not resolve it. The resolution
2841 -- is completed once a suitable subprogram is found.
2845 -- When the renamed name denotes the intrinsic operator equals,
2846 -- the name must be treated as overloaded. This allows for a
2847 -- potential match against the root type's predefined equality
2850 if Is_Intrinsic_Equality
(Entity
(Nam
)) then
2851 Set_Is_Overloaded
(Nam
);
2852 Collect_Interps
(Nam
);
2855 -- Step 1: Find the generic formal type and its corresponding
2856 -- class-wide actual type from the renamed generic formal
2859 Formal
:= First_Formal
(Formal_Spec
);
2860 while Present
(Formal
) loop
2861 if Has_Unknown_Discriminants
(Etype
(Formal
))
2862 and then not Is_Class_Wide_Type
(Etype
(Formal
))
2863 and then Is_Class_Wide_Type
(Get_Instance_Of
(Etype
(Formal
)))
2865 Formal_Typ
:= Etype
(Formal
);
2866 Actual_Typ
:= Base_Type
(Get_Instance_Of
(Formal_Typ
));
2867 Root_Typ
:= Root_Type
(Actual_Typ
);
2871 Next_Formal
(Formal
);
2874 -- The specification of the generic formal subprogram should
2875 -- always contain a formal type with unknown discriminants whose
2876 -- actual is a class-wide type; otherwise this indicates a failure
2877 -- in function Has_Class_Wide_Actual.
2879 pragma Assert
(Present
(Formal_Typ
));
2881 -- Step 2: Find the proper class-wide subprogram or primitive
2882 -- that corresponds to the renamed generic formal subprogram.
2884 CW_Prim_Op
:= Find_Primitive
(Actual_Typ
);
2885 CW_Prim_OK
:= Is_Suitable_Candidate
(CW_Prim_Op
);
2886 Root_Prim_Op
:= Find_Primitive
(Root_Typ
);
2887 Root_Prim_OK
:= Is_Suitable_Candidate
(Root_Prim_Op
);
2889 -- The class-wide actual type has two subprograms that correspond
2890 -- to the renamed generic formal subprogram:
2892 -- with procedure Prim_Op (Param : Formal_Typ);
2894 -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited
2895 -- procedure Prim_Op (Param : Actual_Typ'Class);
2897 -- Even though the declaration of the two subprograms is legal, a
2898 -- call to either one is ambiguous and therefore illegal.
2900 if CW_Prim_OK
and Root_Prim_OK
then
2902 -- A user-defined primitive has precedence over a predefined
2905 if Is_Internal
(CW_Prim_Op
)
2906 and then not Is_Internal
(Root_Prim_Op
)
2908 Prim_Op
:= Root_Prim_Op
;
2910 elsif Is_Internal
(Root_Prim_Op
)
2911 and then not Is_Internal
(CW_Prim_Op
)
2913 Prim_Op
:= CW_Prim_Op
;
2916 elsif CW_Prim_Op
= Root_Prim_Op
then
2917 Prim_Op
:= Root_Prim_Op
;
2919 -- The two subprograms are legal but the class-wide subprogram
2920 -- is a class-wide wrapper built for a previous instantiation;
2921 -- the wrapper has precedence.
2923 elsif Present
(Alias
(CW_Prim_Op
))
2924 and then Is_Class_Wide_Wrapper
(Ultimate_Alias
(CW_Prim_Op
))
2926 Prim_Op
:= CW_Prim_Op
;
2929 -- Otherwise both candidate subprograms are user-defined and
2934 ("ambiguous actual for generic subprogram &",
2936 Interpretation_Error
(Root_Prim_Op
);
2937 Interpretation_Error
(CW_Prim_Op
);
2941 elsif CW_Prim_OK
and not Root_Prim_OK
then
2942 Prim_Op
:= CW_Prim_Op
;
2945 elsif not CW_Prim_OK
and Root_Prim_OK
then
2946 Prim_Op
:= Root_Prim_Op
;
2948 -- An intrinsic equality may act as a suitable candidate in the
2949 -- case of a null type extension where the parent's equality
2950 -- is hidden. A call to an intrinsic equality is expanded as
2953 elsif Present
(Root_Prim_Op
)
2954 and then Is_Intrinsic_Equality
(Root_Prim_Op
)
2956 Prim_Op
:= Root_Prim_Op
;
2958 -- Otherwise there are no candidate subprograms. Let the caller
2959 -- diagnose the error.
2965 -- At this point resolution has taken place and the name is no
2966 -- longer overloaded. Mark the primitive as referenced.
2968 Set_Is_Overloaded
(Name
(N
), False);
2969 Set_Referenced
(Prim_Op
);
2970 end Find_Suitable_Candidate
;
2974 Is_CW_Prim
: Boolean;
2976 -- Start of processing for Handle_Instance_With_Class_Wide_Type
2979 Wrapped_Prim
:= Empty
;
2982 -- Ada 2012 (AI05-0071): A generic/instance scenario involving a
2983 -- formal type with unknown discriminants and a generic primitive
2984 -- operation of the said type with a box require special processing
2985 -- when the actual is a class-wide type:
2988 -- type Formal_Typ (<>) is private;
2989 -- with procedure Prim_Op (Param : Formal_Typ) is <>;
2990 -- package Gen is ...
2992 -- package Inst is new Gen (Actual_Typ'Class);
2994 -- In this case the general renaming mechanism used in the prologue
2995 -- of an instance no longer applies:
2997 -- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op;
2999 -- The above is replaced the following wrapper/renaming combination:
3001 -- procedure Wrapper (Param : Formal_Typ) is -- wrapper
3003 -- Prim_Op (Param); -- primitive
3006 -- procedure Prim_Op (Param : Formal_Typ) renames Wrapper;
3008 -- This transformation applies only if there is no explicit visible
3009 -- class-wide operation at the point of the instantiation. Ren_Id is
3010 -- the entity of the renaming declaration. When the transformation
3011 -- applies, Wrapped_Prim is the entity of the wrapped primitive.
3013 if Box_Present
(Inst_Node
) then
3014 Find_Suitable_Candidate
3015 (Prim_Op
=> Wrapped_Prim
,
3016 Is_CW_Prim
=> Is_CW_Prim
);
3018 if Present
(Wrapped_Prim
) then
3019 if not Is_CW_Prim
then
3020 Build_Class_Wide_Wrapper
(Ren_Id
, Wrapped_Prim
, Wrap_Id
);
3022 -- Small optimization: When the candidate is a class-wide
3023 -- subprogram we don't build the wrapper; we modify the
3024 -- renaming declaration to directly map the actual to the
3025 -- generic formal and discard the candidate.
3028 Rewrite
(Nam
, New_Occurrence_Of
(Wrapped_Prim
, Sloc
(N
)));
3029 Wrapped_Prim
:= Empty
;
3033 -- Ada 2022 (AI12-0165, RM 12.6(8.5/3)): The actual subprogram for a
3034 -- formal_abstract_subprogram_declaration shall be:
3035 -- a) a dispatching operation of the controlling type; or
3036 -- b) if the controlling type is a formal type, and the actual
3037 -- type corresponding to that formal type is a specific type T,
3038 -- a dispatching operation of type T; or
3039 -- c) if the controlling type is a formal type, and the actual
3040 -- type is a class-wide type T'Class, an implicitly declared
3041 -- subprogram corresponding to a primitive operation of type T.
3043 elsif Nkind
(Inst_Node
) = N_Formal_Abstract_Subprogram_Declaration
3044 and then Is_Entity_Name
(Nam
)
3046 Find_Suitable_Candidate
3047 (Prim_Op
=> Wrapped_Prim
,
3048 Is_CW_Prim
=> Is_CW_Prim
);
3050 if Present
(Wrapped_Prim
) then
3052 -- Cases (a) and (b); see previous description.
3054 if not Is_CW_Prim
then
3055 Build_Class_Wide_Wrapper
(Ren_Id
, Wrapped_Prim
, Wrap_Id
);
3057 -- Case (c); see previous description.
3059 -- Implicit operations of T'Class for subtype declarations
3060 -- are built by Derive_Subprogram, and their Alias attribute
3061 -- references the primitive operation of T.
3063 elsif not Comes_From_Source
(Wrapped_Prim
)
3064 and then Nkind
(Parent
(Wrapped_Prim
)) = N_Subtype_Declaration
3065 and then Present
(Alias
(Wrapped_Prim
))
3067 -- We don't need to build the wrapper; we modify the
3068 -- renaming declaration to directly map the actual to
3069 -- the generic formal and discard the candidate.
3072 New_Occurrence_Of
(Alias
(Wrapped_Prim
), Sloc
(N
)));
3073 Wrapped_Prim
:= Empty
;
3075 -- Legality rules do not apply; discard the candidate.
3078 Wrapped_Prim
:= Empty
;
3082 end Handle_Instance_With_Class_Wide_Type
;
3084 -------------------------
3085 -- Original_Subprogram --
3086 -------------------------
3088 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
is
3089 Orig_Decl
: Node_Id
;
3090 Orig_Subp
: Entity_Id
;
3093 -- First case: renamed entity is itself a renaming
3095 if Present
(Alias
(Subp
)) then
3096 return Alias
(Subp
);
3098 elsif Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
3099 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(Subp
)))
3101 -- Check if renamed entity is a renaming_as_body
3104 Unit_Declaration_Node
3105 (Corresponding_Body
(Unit_Declaration_Node
(Subp
)));
3107 if Nkind
(Orig_Decl
) = N_Subprogram_Renaming_Declaration
then
3108 Orig_Subp
:= Entity
(Name
(Orig_Decl
));
3110 if Orig_Subp
= Rename_Spec
then
3112 -- Circularity detected
3117 return (Original_Subprogram
(Orig_Subp
));
3125 end Original_Subprogram
;
3129 CW_Actual
: constant Boolean := Has_Class_Wide_Actual
;
3130 -- Ada 2012 (AI05-071, AI05-0131) and Ada 2022 (AI12-0165): True if the
3131 -- renaming is for a defaulted formal subprogram when the actual for a
3132 -- related formal type is class-wide.
3134 Inst_Node
: Node_Id
:= Empty
;
3135 New_S
: Entity_Id
:= Empty
;
3136 Wrapped_Prim
: Entity_Id
:= Empty
;
3138 -- Start of processing for Analyze_Subprogram_Renaming
3141 -- We must test for the attribute renaming case before the Analyze
3142 -- call because otherwise Sem_Attr will complain that the attribute
3143 -- is missing an argument when it is analyzed.
3145 if Nkind
(Nam
) = N_Attribute_Reference
then
3147 -- In the case of an abstract formal subprogram association, rewrite
3148 -- an actual given by a stream or Put_Image attribute as the name of
3149 -- the corresponding stream or Put_Image primitive of the type.
3151 -- In a generic context the stream and Put_Image operations are not
3152 -- generated, and this must be treated as a normal attribute
3153 -- reference, to be expanded in subsequent instantiations.
3156 and then Is_Abstract_Subprogram
(Formal_Spec
)
3157 and then Expander_Active
3160 Prefix_Type
: constant Entity_Id
:= Entity
(Prefix
(Nam
));
3164 -- The class-wide forms of the stream and Put_Image attributes
3165 -- are not primitive dispatching operations (even though they
3166 -- internally dispatch).
3168 if Is_Class_Wide_Type
(Prefix_Type
) then
3170 ("attribute must be a primitive dispatching operation",
3175 -- Retrieve the primitive subprogram associated with the
3176 -- attribute. This can only be a stream attribute, since those
3177 -- are the only ones that are dispatching (and the actual for
3178 -- an abstract formal subprogram must be dispatching
3181 case Attribute_Name
(Nam
) is
3184 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Input
);
3188 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Output
);
3192 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Read
);
3196 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Write
);
3198 when Name_Put_Image
=>
3200 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Put_Image
);
3204 ("attribute must be a primitive dispatching operation",
3209 -- If no stream operation was found, and the type is limited,
3210 -- the user should have defined one. This rule does not apply
3214 and then Attribute_Name
(Nam
) /= Name_Put_Image
3216 if Is_Limited_Type
(Prefix_Type
) then
3218 ("stream operation not defined for type&",
3222 -- Otherwise, compiler should have generated default
3225 raise Program_Error
;
3229 -- Rewrite the attribute into the name of its corresponding
3230 -- primitive dispatching subprogram. We can then proceed with
3231 -- the usual processing for subprogram renamings.
3234 Prim_Name
: constant Node_Id
:=
3235 Make_Identifier
(Sloc
(Nam
),
3236 Chars
=> Chars
(Prim
));
3238 Set_Entity
(Prim_Name
, Prim
);
3239 Rewrite
(Nam
, Prim_Name
);
3244 -- Normal processing for a renaming of an attribute
3247 Attribute_Renaming
(N
);
3252 -- Check whether this declaration corresponds to the instantiation of a
3253 -- formal subprogram.
3255 -- If this is an instantiation, the corresponding actual is frozen and
3256 -- error messages can be made more precise. If this is a default
3257 -- subprogram, the entity is already established in the generic, and is
3258 -- not retrieved by visibility. If it is a default with a box, the
3259 -- candidate interpretations, if any, have been collected when building
3260 -- the renaming declaration. If overloaded, the proper interpretation is
3261 -- determined in Find_Renamed_Entity. If the entity is an operator,
3262 -- Find_Renamed_Entity applies additional visibility checks.
3265 Inst_Node
:= Unit_Declaration_Node
(Formal_Spec
);
3267 -- Ada 2012 (AI05-0071) and Ada 2022 (AI12-0165): when the actual
3268 -- type is a class-wide type T'Class we may need to wrap a primitive
3269 -- operation of T. Search for the wrapped primitive and (if required)
3270 -- build a wrapper whose body consists of a dispatching call to the
3271 -- wrapped primitive of T, with its formal parameters as the actual
3274 if CW_Actual
and then
3276 -- Ada 2012 (AI05-0071): Check whether the renaming is for a
3277 -- defaulted actual subprogram with a class-wide actual.
3279 (Box_Present
(Inst_Node
)
3283 -- Ada 2022 (AI12-0165): Check whether the renaming is for a formal
3284 -- abstract subprogram declaration with a class-wide actual.
3286 (Nkind
(Inst_Node
) = N_Formal_Abstract_Subprogram_Declaration
3287 and then Is_Entity_Name
(Nam
)))
3289 New_S
:= Analyze_Subprogram_Specification
(Spec
);
3291 -- Do not attempt to build the wrapper if the renaming is in error
3293 if not Error_Posted
(Nam
) then
3294 Handle_Instance_With_Class_Wide_Type
3295 (Inst_Node
=> Inst_Node
,
3297 Wrapped_Prim
=> Wrapped_Prim
,
3300 -- If several candidates were found, then we reported the
3301 -- ambiguity; stop processing the renaming declaration to
3302 -- avoid reporting further (spurious) errors.
3304 if Error_Posted
(Spec
) then
3311 if Present
(Wrapped_Prim
) then
3313 -- When the wrapper is built, the subprogram renaming aliases
3318 pragma Assert
(Old_S
= Entity
(Nam
)
3319 and then Is_Class_Wide_Wrapper
(Old_S
));
3321 -- The subprogram renaming declaration may become Ghost if it
3322 -- renames a wrapper of a Ghost entity.
3324 Mark_Ghost_Renaming
(N
, Wrapped_Prim
);
3326 elsif Is_Entity_Name
(Nam
)
3327 and then Present
(Entity
(Nam
))
3328 and then not Comes_From_Source
(Nam
)
3329 and then not Is_Overloaded
(Nam
)
3331 Old_S
:= Entity
(Nam
);
3333 -- The subprogram renaming declaration may become Ghost if it
3334 -- renames a Ghost entity.
3336 Mark_Ghost_Renaming
(N
, Old_S
);
3338 New_S
:= Analyze_Subprogram_Specification
(Spec
);
3342 if Ekind
(Old_S
) = E_Operator
then
3346 if Box_Present
(Inst_Node
) then
3347 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
3349 -- If there is an immediately visible homonym of the operator
3350 -- and the declaration has a default, this is worth a warning
3351 -- because the user probably did not intend to get the pre-
3352 -- defined operator, visible in the generic declaration. To
3353 -- find if there is an intended candidate, analyze the renaming
3354 -- again in the current context.
3356 elsif Scope
(Old_S
) = Standard_Standard
3357 and then Present
(Default_Name
(Inst_Node
))
3360 Decl
: constant Node_Id
:= New_Copy_Tree
(N
);
3364 Set_Entity
(Name
(Decl
), Empty
);
3365 Analyze
(Name
(Decl
));
3367 Find_Renamed_Entity
(Decl
, Name
(Decl
), New_S
, True);
3370 and then In_Open_Scopes
(Scope
(Hidden
))
3371 and then Is_Immediately_Visible
(Hidden
)
3372 and then Comes_From_Source
(Hidden
)
3373 and then Hidden
/= Old_S
3375 Error_Msg_Sloc
:= Sloc
(Hidden
);
3377 ("default subprogram is resolved in the generic "
3378 & "declaration (RM 12.6(17))??", N
);
3379 Error_Msg_NE
("\and will not use & #??", N
, Hidden
);
3388 -- The subprogram renaming declaration may become Ghost if it
3389 -- renames a Ghost entity.
3391 if Is_Entity_Name
(Nam
) then
3392 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
3395 New_S
:= Analyze_Subprogram_Specification
(Spec
);
3399 -- Renamed entity must be analyzed first, to avoid being hidden by
3400 -- new name (which might be the same in a generic instance).
3404 -- The subprogram renaming declaration may become Ghost if it renames
3407 if Is_Entity_Name
(Nam
) then
3408 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
3411 -- The renaming defines a new overloaded entity, which is analyzed
3412 -- like a subprogram declaration.
3414 New_S
:= Analyze_Subprogram_Specification
(Spec
);
3417 if Current_Scope
/= Standard_Standard
then
3418 Set_Is_Pure
(New_S
, Is_Pure
(Current_Scope
));
3421 -- Set SPARK mode from current context
3423 Set_SPARK_Pragma
(New_S
, SPARK_Mode_Pragma
);
3424 Set_SPARK_Pragma_Inherited
(New_S
);
3426 Rename_Spec
:= Find_Corresponding_Spec
(N
);
3428 -- Case of Renaming_As_Body
3430 if Present
(Rename_Spec
) then
3431 Check_Previous_Null_Procedure
(N
, Rename_Spec
);
3433 -- Renaming declaration is the completion of the declaration of
3434 -- Rename_Spec. We build an actual body for it at the freezing point.
3436 Set_Corresponding_Spec
(N
, Rename_Spec
);
3438 -- Deal with special case of stream functions of abstract types
3441 if Nkind
(Unit_Declaration_Node
(Rename_Spec
)) =
3442 N_Abstract_Subprogram_Declaration
3444 -- Input stream functions are abstract if the object type is
3445 -- abstract. Similarly, all default stream functions for an
3446 -- interface type are abstract. However, these subprograms may
3447 -- receive explicit declarations in representation clauses, making
3448 -- the attribute subprograms usable as defaults in subsequent
3450 -- In this case we rewrite the declaration to make the subprogram
3451 -- non-abstract. We remove the previous declaration, and insert
3452 -- the new one at the point of the renaming, to prevent premature
3453 -- access to unfrozen types. The new declaration reuses the
3454 -- specification of the previous one, and must not be analyzed.
3457 (Is_Primitive
(Entity
(Nam
))
3459 Is_Abstract_Type
(Find_Dispatching_Type
(Entity
(Nam
))));
3461 Old_Decl
: constant Node_Id
:=
3462 Unit_Declaration_Node
(Rename_Spec
);
3463 New_Decl
: constant Node_Id
:=
3464 Make_Subprogram_Declaration
(Sloc
(N
),
3466 Relocate_Node
(Specification
(Old_Decl
)));
3469 Insert_After
(N
, New_Decl
);
3470 Set_Is_Abstract_Subprogram
(Rename_Spec
, False);
3471 Set_Analyzed
(New_Decl
);
3475 Set_Corresponding_Body
(Unit_Declaration_Node
(Rename_Spec
), New_S
);
3477 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3478 Error_Msg_N
("(Ada 83) renaming cannot serve as a body", N
);
3481 Set_Convention
(New_S
, Convention
(Rename_Spec
));
3482 Check_Fully_Conformant
(New_S
, Rename_Spec
);
3483 Set_Public_Status
(New_S
);
3485 if No_Return
(Rename_Spec
)
3486 and then not No_Return
(Entity
(Nam
))
3489 ("renamed subprogram & must be No_Return", N
, Entity
(Nam
));
3491 ("\since renaming subprogram is No_Return (RM 6.5.1(7/2))", N
);
3494 -- The specification does not introduce new formals, but only
3495 -- repeats the formals of the original subprogram declaration.
3496 -- For cross-reference purposes, and for refactoring tools, we
3497 -- treat the formals of the renaming declaration as body formals.
3499 Reference_Body_Formals
(Rename_Spec
, New_S
);
3501 -- Indicate that the entity in the declaration functions like the
3502 -- corresponding body, and is not a new entity. The body will be
3503 -- constructed later at the freeze point, so indicate that the
3504 -- completion has not been seen yet.
3506 Reinit_Field_To_Zero
(New_S
, F_Has_Out_Or_In_Out_Parameter
,
3507 Old_Ekind
=> (E_Function | E_Procedure
=> True, others => False));
3508 Reinit_Field_To_Zero
(New_S
, F_Needs_No_Actuals
);
3509 Reinit_Field_To_Zero
(New_S
, F_Is_Predicate_Function
);
3510 Reinit_Field_To_Zero
(New_S
, F_Protected_Subprogram
);
3511 Reinit_Field_To_Zero
(New_S
, F_Is_Inlined_Always
);
3512 Reinit_Field_To_Zero
(New_S
, F_Is_Generic_Actual_Subprogram
);
3513 Mutate_Ekind
(New_S
, E_Subprogram_Body
);
3514 New_S
:= Rename_Spec
;
3515 Set_Has_Completion
(Rename_Spec
, False);
3517 -- Ada 2005: check overriding indicator
3519 if Present
(Overridden_Operation
(Rename_Spec
)) then
3520 if Must_Not_Override
(Specification
(N
)) then
3522 ("subprogram& overrides inherited operation",
3526 and then not Must_Override
(Specification
(N
))
3528 Style
.Missing_Overriding
(N
, Rename_Spec
);
3531 elsif Must_Override
(Specification
(N
))
3532 and then not Can_Override_Operator
(Rename_Spec
)
3534 Error_Msg_NE
("subprogram& is not overriding", N
, Rename_Spec
);
3537 -- AI12-0132: a renames-as-body freezes the expression of any
3538 -- expression function that it renames.
3540 if Is_Entity_Name
(Nam
)
3541 and then Is_Expression_Function
(Entity
(Nam
))
3542 and then not Inside_A_Generic
3545 (Def_Id
=> Entity
(Nam
),
3546 Typ
=> Etype
(Entity
(Nam
)),
3549 (Original_Node
(Unit_Declaration_Node
(Entity
(Nam
)))),
3553 -- Normal subprogram renaming (not renaming as body)
3556 Generate_Definition
(New_S
);
3557 New_Overloaded_Entity
(New_S
);
3559 if not (Is_Entity_Name
(Nam
)
3560 and then Is_Intrinsic_Subprogram
(Entity
(Nam
)))
3562 Check_Delayed_Subprogram
(New_S
);
3565 -- Verify that a SPARK renaming does not declare a primitive
3566 -- operation of a tagged type.
3568 Check_SPARK_Primitive_Operation
(New_S
);
3571 -- There is no need for elaboration checks on the new entity, which may
3572 -- be called before the next freezing point where the body will appear.
3573 -- Elaboration checks refer to the real entity, not the one created by
3574 -- the renaming declaration.
3576 Set_Kill_Elaboration_Checks
(New_S
, True);
3578 -- If we had a previous error, indicate a completion is present to stop
3579 -- junk cascaded messages, but don't take any further action.
3581 if Etype
(Nam
) = Any_Type
then
3582 Set_Has_Completion
(New_S
);
3585 -- Case where name has the form of a selected component
3587 elsif Nkind
(Nam
) = N_Selected_Component
then
3589 -- A name which has the form A.B can designate an entry of task A, a
3590 -- protected operation of protected object A, or finally a primitive
3591 -- operation of object A. In the later case, A is an object of some
3592 -- tagged type, or an access type that denotes one such. To further
3593 -- distinguish these cases, note that the scope of a task entry or
3594 -- protected operation is type of the prefix.
3596 -- The prefix could be an overloaded function call that returns both
3597 -- kinds of operations. This overloading pathology is left to the
3598 -- dedicated reader ???
3601 T
: constant Entity_Id
:= Etype
(Prefix
(Nam
));
3609 and then Is_Tagged_Type
(Designated_Type
(T
))))
3610 and then Scope
(Entity
(Selector_Name
(Nam
))) /= T
3612 Analyze_Renamed_Primitive_Operation
3613 (N
, New_S
, Present
(Rename_Spec
));
3617 -- Renamed entity is an entry or protected operation. For those
3618 -- cases an explicit body is built (at the point of freezing of
3619 -- this entity) that contains a call to the renamed entity.
3621 -- This is not allowed for renaming as body if the renamed
3622 -- spec is already frozen (see RM 8.5.4(5) for details).
3624 if Present
(Rename_Spec
) and then Is_Frozen
(Rename_Spec
) then
3626 ("renaming-as-body cannot rename entry as subprogram", N
);
3628 ("\since & is already frozen (RM 8.5.4(5))",
3631 Analyze_Renamed_Entry
(N
, New_S
, Present
(Rename_Spec
));
3638 -- Case where name is an explicit dereference X.all
3640 elsif Nkind
(Nam
) = N_Explicit_Dereference
then
3642 -- Renamed entity is designated by access_to_subprogram expression.
3643 -- Must build body to encapsulate call, as in the entry case.
3645 Analyze_Renamed_Dereference
(N
, New_S
, Present
(Rename_Spec
));
3648 -- Indexed component
3650 elsif Nkind
(Nam
) = N_Indexed_Component
then
3651 Analyze_Renamed_Family_Member
(N
, New_S
, Present
(Rename_Spec
));
3654 -- Character literal
3656 elsif Nkind
(Nam
) = N_Character_Literal
then
3657 Analyze_Renamed_Character
(N
, New_S
, Present
(Rename_Spec
));
3660 -- Only remaining case is where we have a non-entity name, or a renaming
3661 -- of some other non-overloadable entity.
3663 elsif not Is_Entity_Name
(Nam
)
3664 or else not Is_Overloadable
(Entity
(Nam
))
3666 -- Do not mention the renaming if it comes from an instance
3668 if not Is_Actual
then
3669 Error_Msg_N
("expect valid subprogram name in renaming", N
);
3671 Error_Msg_NE
("no visible subprogram for formal&", N
, Nam
);
3677 -- Find the renamed entity that matches the given specification. Disable
3678 -- Ada_83 because there is no requirement of full conformance between
3679 -- renamed entity and new entity, even though the same circuit is used.
3681 -- This is a bit of an odd case, which introduces a really irregular use
3682 -- of Ada_Version[_Explicit]. Would be nice to find cleaner way to do
3685 Ada_Version
:= Ada_Version_Type
'Max (Ada_Version
, Ada_95
);
3686 Ada_Version_Pragma
:= Empty
;
3687 Ada_Version_Explicit
:= Ada_Version
;
3690 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
3692 -- The visible operation may be an inherited abstract operation that
3693 -- was overridden in the private part, in which case a call will
3694 -- dispatch to the overriding operation. Use the overriding one in
3695 -- the renaming declaration, to prevent spurious errors below.
3697 if Is_Overloadable
(Old_S
)
3698 and then Is_Abstract_Subprogram
(Old_S
)
3699 and then No
(DTC_Entity
(Old_S
))
3700 and then Present
(Alias
(Old_S
))
3701 and then not Is_Abstract_Subprogram
(Alias
(Old_S
))
3702 and then Present
(Overridden_Operation
(Alias
(Old_S
)))
3704 Old_S
:= Alias
(Old_S
);
3707 -- When the renamed subprogram is overloaded and used as an actual
3708 -- of a generic, its entity is set to the first available homonym.
3709 -- We must first disambiguate the name, then set the proper entity.
3711 if Is_Actual
and then Is_Overloaded
(Nam
) then
3712 Set_Entity
(Nam
, Old_S
);
3716 -- Most common case: subprogram renames subprogram. No body is generated
3717 -- in this case, so we must indicate the declaration is complete as is.
3718 -- and inherit various attributes of the renamed subprogram.
3720 if No
(Rename_Spec
) then
3721 Set_Has_Completion
(New_S
);
3722 Set_Is_Imported
(New_S
, Is_Imported
(Entity
(Nam
)));
3723 Set_Is_Pure
(New_S
, Is_Pure
(Entity
(Nam
)));
3724 Set_Is_Preelaborated
(New_S
, Is_Preelaborated
(Entity
(Nam
)));
3726 -- Ada 2005 (AI-423): Check the consistency of null exclusions
3727 -- between a subprogram and its correct renaming.
3729 -- Note: the Any_Id check is a guard that prevents compiler crashes
3730 -- when performing a null exclusion check between a renaming and a
3731 -- renamed subprogram that has been found to be illegal.
3733 if Ada_Version
>= Ada_2005
and then Entity
(Nam
) /= Any_Id
then
3734 Check_Null_Exclusion
3736 Sub
=> Entity
(Nam
));
3739 -- Enforce the Ada 2005 rule that the renamed entity cannot require
3740 -- overriding. The flag Requires_Overriding is set very selectively
3741 -- and misses some other illegal cases. The additional conditions
3742 -- checked below are sufficient but not necessary ???
3744 -- The rule does not apply to the renaming generated for an actual
3745 -- subprogram in an instance.
3750 -- Guard against previous errors, and omit renamings of predefined
3753 elsif Ekind
(Old_S
) not in E_Function | E_Procedure
then
3756 elsif Requires_Overriding
(Old_S
)
3758 (Is_Abstract_Subprogram
(Old_S
)
3759 and then Present
(Find_Dispatching_Type
(Old_S
))
3760 and then not Is_Abstract_Type
(Find_Dispatching_Type
(Old_S
)))
3763 ("renamed entity cannot be subprogram that requires overriding "
3764 & "(RM 8.5.4 (5.1))", N
);
3768 Prev
: constant Entity_Id
:= Overridden_Operation
(New_S
);
3772 (Has_Non_Trivial_Precondition
(Prev
)
3773 or else Has_Non_Trivial_Precondition
(Old_S
))
3776 ("conflicting inherited classwide preconditions in renaming "
3777 & "of& (RM 6.1.1 (17)", N
, Old_S
);
3782 if Old_S
/= Any_Id
then
3783 if Is_Actual
and then From_Default
(N
) then
3785 -- This is an implicit reference to the default actual
3787 Generate_Reference
(Old_S
, Nam
, Typ
=> 'i', Force
=> True);
3790 Generate_Reference
(Old_S
, Nam
);
3793 Check_Internal_Protected_Use
(N
, Old_S
);
3795 -- For a renaming-as-body, require subtype conformance, but if the
3796 -- declaration being completed has not been frozen, then inherit the
3797 -- convention of the renamed subprogram prior to checking conformance
3798 -- (unless the renaming has an explicit convention established; the
3799 -- rule stated in the RM doesn't seem to address this ???).
3801 if Present
(Rename_Spec
) then
3802 Generate_Reference
(Rename_Spec
, Defining_Entity
(Spec
), 'b');
3803 Style
.Check_Identifier
(Defining_Entity
(Spec
), Rename_Spec
);
3805 if not Is_Frozen
(Rename_Spec
) then
3806 if not Has_Convention_Pragma
(Rename_Spec
) then
3807 Set_Convention
(New_S
, Convention
(Old_S
));
3810 if Ekind
(Old_S
) /= E_Operator
then
3811 Check_Mode_Conformant
(New_S
, Old_S
, Spec
);
3814 if Original_Subprogram
(Old_S
) = Rename_Spec
then
3815 Error_Msg_N
("unfrozen subprogram cannot rename itself", N
);
3817 Check_Formal_Subprogram_Conformance
(New_S
, Old_S
, Spec
);
3820 Check_Subtype_Conformant
(New_S
, Old_S
, Spec
);
3823 Check_Frozen_Renaming
(N
, Rename_Spec
);
3825 -- Check explicitly that renamed entity is not intrinsic, because
3826 -- in a generic the renamed body is not built. In this case,
3827 -- the renaming_as_body is a completion.
3829 if Inside_A_Generic
then
3830 if Is_Frozen
(Rename_Spec
)
3831 and then Is_Intrinsic_Subprogram
(Old_S
)
3834 ("subprogram in renaming_as_body cannot be intrinsic",
3838 Set_Has_Completion
(Rename_Spec
);
3841 elsif Ekind
(Old_S
) /= E_Operator
then
3843 -- If this a defaulted subprogram for a class-wide actual there is
3844 -- no check for mode conformance, given that the signatures don't
3845 -- match (the source mentions T but the actual mentions T'Class).
3850 -- No need for a redundant error message if this is a nested
3851 -- instance, unless the current instantiation (of a child unit)
3852 -- is a compilation unit, which is not analyzed when the parent
3853 -- generic is analyzed.
3856 or else No
(Enclosing_Instance
)
3857 or else Is_Compilation_Unit
(Current_Scope
)
3859 Check_Mode_Conformant
(New_S
, Old_S
);
3863 if No
(Rename_Spec
) then
3865 -- The parameter profile of the new entity is that of the renamed
3866 -- entity: the subtypes given in the specification are irrelevant.
3868 Inherit_Renamed_Profile
(New_S
, Old_S
);
3870 -- A call to the subprogram is transformed into a call to the
3871 -- renamed entity. This is transitive if the renamed entity is
3872 -- itself a renaming.
3874 if Present
(Alias
(Old_S
)) then
3875 Set_Alias
(New_S
, Alias
(Old_S
));
3877 Set_Alias
(New_S
, Old_S
);
3880 -- Note that we do not set Is_Intrinsic_Subprogram if we have a
3881 -- renaming as body, since the entity in this case is not an
3882 -- intrinsic (it calls an intrinsic, but we have a real body for
3883 -- this call, and it is in this body that the required intrinsic
3884 -- processing will take place).
3886 -- Also, if this is a renaming of inequality, the renamed operator
3887 -- is intrinsic, but what matters is the corresponding equality
3888 -- operator, which may be user-defined.
3890 Set_Is_Intrinsic_Subprogram
3892 Is_Intrinsic_Subprogram
(Old_S
)
3894 (Chars
(Old_S
) /= Name_Op_Ne
3895 or else Ekind
(Old_S
) = E_Operator
3896 or else Is_Intrinsic_Subprogram
3897 (Corresponding_Equality
(Old_S
))));
3899 if Ekind
(Alias
(New_S
)) = E_Operator
then
3900 Set_Has_Delayed_Freeze
(New_S
, False);
3903 -- If the renaming corresponds to an association for an abstract
3904 -- formal subprogram, then various attributes must be set to
3905 -- indicate that the renaming is an abstract dispatching operation
3906 -- with a controlling type.
3908 -- Skip this decoration when the renaming corresponds to an
3909 -- association with class-wide wrapper (see above) because such
3910 -- wrapper is neither abstract nor a dispatching operation (its
3911 -- body has the dispatching call to the wrapped primitive).
3914 and then Is_Abstract_Subprogram
(Formal_Spec
)
3915 and then No
(Wrapped_Prim
)
3918 -- Mark the renaming as abstract here, so Find_Dispatching_Type
3919 -- see it as corresponding to a generic association for a
3920 -- formal abstract subprogram
3922 Set_Is_Abstract_Subprogram
(New_S
);
3925 New_S_Ctrl_Type
: constant Entity_Id
:=
3926 Find_Dispatching_Type
(New_S
);
3927 Old_S_Ctrl_Type
: constant Entity_Id
:=
3928 Find_Dispatching_Type
(Old_S
);
3932 -- The actual must match the (instance of the) formal,
3933 -- and must be a controlling type.
3935 if Old_S_Ctrl_Type
/= New_S_Ctrl_Type
3936 or else No
(New_S_Ctrl_Type
)
3938 if No
(New_S_Ctrl_Type
) then
3940 ("actual must be dispatching subprogram", Nam
);
3943 ("actual must be dispatching subprogram for type&",
3944 Nam
, New_S_Ctrl_Type
);
3948 Set_Is_Dispatching_Operation
(New_S
);
3949 Check_Controlling_Formals
(New_S_Ctrl_Type
, New_S
);
3951 -- If the actual in the formal subprogram is itself a
3952 -- formal abstract subprogram association, there's no
3953 -- dispatch table component or position to inherit.
3955 if Present
(DTC_Entity
(Old_S
)) then
3956 Set_DTC_Entity
(New_S
, DTC_Entity
(Old_S
));
3957 Set_DT_Position_Value
(New_S
, DT_Position
(Old_S
));
3967 -- The following is illegal, because F hides whatever other F may
3969 -- function F (...) renames F;
3972 or else (Nkind
(Nam
) /= N_Expanded_Name
3973 and then Chars
(Old_S
) = Chars
(New_S
))
3975 Error_Msg_N
("subprogram cannot rename itself", N
);
3977 -- This is illegal even if we use a selector:
3978 -- function F (...) renames Pkg.F;
3979 -- because F is still hidden.
3981 elsif Nkind
(Nam
) = N_Expanded_Name
3982 and then Entity
(Prefix
(Nam
)) = Current_Scope
3983 and then Chars
(Selector_Name
(Nam
)) = Chars
(New_S
)
3985 -- This is an error, but we overlook the error and accept the
3986 -- renaming if the special Overriding_Renamings mode is in effect.
3988 if not Overriding_Renamings
then
3990 ("implicit operation& is not visible (RM 8.3 (15))",
3994 -- Check whether an expanded name used for the renamed subprogram
3995 -- begins with the same name as the renaming itself, and if so,
3996 -- issue an error about the prefix being hidden by the renaming.
3997 -- We exclude generic instances from this checking, since such
3998 -- normally illegal renamings can be constructed when expanding
4001 elsif Nkind
(Nam
) = N_Expanded_Name
and then not In_Instance
then
4003 function Ult_Expanded_Prefix
(N
: Node_Id
) return Node_Id
is
4004 (if Nkind
(N
) /= N_Expanded_Name
4006 else Ult_Expanded_Prefix
(Prefix
(N
)));
4007 -- Returns the ultimate prefix of an expanded name
4010 if Chars
(Entity
(Ult_Expanded_Prefix
(Nam
))) = Chars
(New_S
)
4012 Error_Msg_Sloc
:= Sloc
(N
);
4014 ("& is hidden by declaration#", Nam
, New_S
);
4019 Set_Convention
(New_S
, Convention
(Old_S
));
4021 if Is_Abstract_Subprogram
(Old_S
) then
4022 if Present
(Rename_Spec
) then
4024 ("a renaming-as-body cannot rename an abstract subprogram",
4026 Set_Has_Completion
(Rename_Spec
);
4028 Set_Is_Abstract_Subprogram
(New_S
);
4032 Check_Library_Unit_Renaming
(N
, Old_S
);
4034 -- Pathological case: procedure renames entry in the scope of its
4035 -- task. Entry is given by simple name, but body must be built for
4036 -- procedure. Of course if called it will deadlock.
4038 if Ekind
(Old_S
) = E_Entry
then
4039 Set_Has_Completion
(New_S
, False);
4040 Set_Alias
(New_S
, Empty
);
4043 -- Do not freeze the renaming nor the renamed entity when the context
4044 -- is an enclosing generic. Freezing is an expansion activity, and in
4045 -- addition the renamed entity may depend on the generic formals of
4046 -- the enclosing generic.
4048 if Is_Actual
and not Inside_A_Generic
then
4049 Freeze_Before
(N
, Old_S
);
4050 Freeze_Actual_Profile
;
4051 Set_Has_Delayed_Freeze
(New_S
, False);
4052 Freeze_Before
(N
, New_S
);
4054 if (Ekind
(Old_S
) = E_Procedure
or else Ekind
(Old_S
) = E_Function
)
4055 and then not Is_Abstract_Subprogram
(Formal_Spec
)
4057 -- An abstract subprogram is only allowed as an actual in the
4058 -- case where the formal subprogram is also abstract.
4060 if Is_Abstract_Subprogram
(Old_S
) then
4062 ("abstract subprogram not allowed as generic actual", Nam
);
4065 -- AI12-0412: A primitive of an abstract type with Pre'Class
4066 -- or Post'Class aspects specified with nonstatic expressions
4067 -- is not allowed as actual for a nonabstract formal subprogram
4068 -- (see RM 6.1.1(18.2/5).
4070 if Is_Dispatching_Operation
(Old_S
)
4072 Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
(Old_S
)
4075 ("primitive of abstract type with nonstatic class-wide "
4076 & "pre/postconditions not allowed as actual",
4083 -- A common error is to assume that implicit operators for types are
4084 -- defined in Standard, or in the scope of a subtype. In those cases
4085 -- where the renamed entity is given with an expanded name, it is
4086 -- worth mentioning that operators for the type are not declared in
4087 -- the scope given by the prefix.
4089 if Nkind
(Nam
) = N_Expanded_Name
4090 and then Nkind
(Selector_Name
(Nam
)) = N_Operator_Symbol
4091 and then Scope
(Entity
(Nam
)) = Standard_Standard
4094 T
: constant Entity_Id
:=
4095 Base_Type
(Etype
(First_Formal
(New_S
)));
4097 Error_Msg_Node_2
:= Prefix
(Nam
);
4099 ("operator for type& is not declared in&", Prefix
(Nam
), T
);
4104 ("no visible subprogram matches the specification for&",
4108 if Present
(Candidate_Renaming
) then
4115 F1
:= First_Formal
(Candidate_Renaming
);
4116 F2
:= First_Formal
(New_S
);
4117 T1
:= First_Subtype
(Etype
(F1
));
4118 while Present
(F1
) and then Present
(F2
) loop
4123 if Present
(F1
) and then Present
(Default_Value
(F1
)) then
4124 if Present
(Next_Formal
(F1
)) then
4126 ("\missing specification for & and other formals with "
4127 & "defaults", Spec
, F1
);
4129 Error_Msg_NE
("\missing specification for &", Spec
, F1
);
4133 if Nkind
(Nam
) = N_Operator_Symbol
4134 and then From_Default
(N
)
4136 Error_Msg_Node_2
:= T1
;
4138 ("default & on & is not directly visible", Nam
, Nam
);
4144 -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that
4145 -- controlling access parameters are known non-null for the renamed
4146 -- subprogram. Test also applies to a subprogram instantiation that
4147 -- is dispatching. Test is skipped if some previous error was detected
4148 -- that set Old_S to Any_Id.
4150 if Ada_Version
>= Ada_2005
4151 and then Old_S
/= Any_Id
4152 and then not Is_Dispatching_Operation
(Old_S
)
4153 and then Is_Dispatching_Operation
(New_S
)
4160 Old_F
:= First_Formal
(Old_S
);
4161 New_F
:= First_Formal
(New_S
);
4162 while Present
(Old_F
) loop
4163 if Ekind
(Etype
(Old_F
)) = E_Anonymous_Access_Type
4164 and then Is_Controlling_Formal
(New_F
)
4165 and then not Can_Never_Be_Null
(Old_F
)
4167 Error_Msg_N
("access parameter is controlling,", New_F
);
4169 ("\corresponding parameter of& must be explicitly null "
4170 & "excluding", New_F
, Old_S
);
4173 Next_Formal
(Old_F
);
4174 Next_Formal
(New_F
);
4179 -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005)
4180 -- is to warn if an operator is being renamed as a different operator.
4181 -- If the operator is predefined, examine the kind of the entity, not
4182 -- the abbreviated declaration in Standard.
4184 if Comes_From_Source
(N
)
4185 and then Present
(Old_S
)
4186 and then (Nkind
(Old_S
) = N_Defining_Operator_Symbol
4187 or else Ekind
(Old_S
) = E_Operator
)
4188 and then Nkind
(New_S
) = N_Defining_Operator_Symbol
4189 and then Chars
(Old_S
) /= Chars
(New_S
)
4192 ("& is being renamed as a different operator??", N
, Old_S
);
4195 -- Check for renaming of obsolescent subprogram
4197 Check_Obsolescent_2005_Entity
(Entity
(Nam
), Nam
);
4199 -- Another warning or some utility: if the new subprogram as the same
4200 -- name as the old one, the old one is not hidden by an outer homograph,
4201 -- the new one is not a public symbol, and the old one is otherwise
4202 -- directly visible, the renaming is superfluous.
4204 if Chars
(Old_S
) = Chars
(New_S
)
4205 and then Comes_From_Source
(N
)
4206 and then Scope
(Old_S
) /= Standard_Standard
4207 and then Warn_On_Redundant_Constructs
4208 and then (Is_Immediately_Visible
(Old_S
)
4209 or else Is_Potentially_Use_Visible
(Old_S
))
4210 and then Is_Overloadable
(Current_Scope
)
4211 and then Chars
(Current_Scope
) /= Chars
(Old_S
)
4214 ("redundant renaming, entity is directly visible?r?", Name
(N
));
4217 -- Implementation-defined aspect specifications can appear in a renaming
4218 -- declaration, but not language-defined ones. The call to procedure
4219 -- Analyze_Aspect_Specifications will take care of this error check.
4221 Analyze_Aspect_Specifications
(N
, New_S
);
4226 and then Has_Yield_Aspect
(Formal_Spec
)
4227 and then not Has_Yield_Aspect
(Old_S
)
4229 Error_Msg_Name_1
:= Name_Yield
;
4231 ("actual subprogram& must have aspect% to match formal", Name
(N
));
4234 Ada_Version
:= Save_AV
;
4235 Ada_Version_Pragma
:= Save_AVP
;
4236 Ada_Version_Explicit
:= Save_AV_Exp
;
4238 -- Check if we are looking at an Ada 2012 defaulted formal subprogram
4239 -- and mark any use_package_clauses that affect the visibility of the
4240 -- implicit generic actual.
4242 -- Also, we may be looking at an internal renaming of a user-defined
4243 -- subprogram created for a generic formal subprogram association,
4244 -- which will also have to be marked here. This can occur when the
4245 -- corresponding formal subprogram contains references to other generic
4248 if Is_Generic_Actual_Subprogram
(New_S
)
4249 and then (Is_Intrinsic_Subprogram
(New_S
)
4250 or else From_Default
(N
)
4251 or else Nkind
(N
) = N_Subprogram_Renaming_Declaration
)
4253 Mark_Use_Clauses
(New_S
);
4255 -- Handle overloaded subprograms
4257 if Present
(Alias
(New_S
)) then
4258 Mark_Use_Clauses
(Alias
(New_S
));
4263 Local_Restrict
.Check_Actual_Subprogram_For_Instance
4264 (Actual_Subp_Name
=> Nam
, Formal_Subp
=> Formal_Spec
);
4266 end Analyze_Subprogram_Renaming
;
4268 -------------------------
4269 -- Analyze_Use_Package --
4270 -------------------------
4272 -- Resolve the package names in the use clause, and make all the visible
4273 -- entities defined in the package potentially use-visible. If the package
4274 -- is already in use from a previous use clause, its visible entities are
4275 -- already use-visible. In that case, mark the occurrence as a redundant
4276 -- use. If the package is an open scope, i.e. if the use clause occurs
4277 -- within the package itself, ignore it.
4279 procedure Analyze_Use_Package
(N
: Node_Id
; Chain
: Boolean := True) is
4280 procedure Analyze_Package_Name
(Clause
: Node_Id
);
4281 -- Perform analysis on a package name from a use_package_clause
4283 procedure Analyze_Package_Name_List
(Head_Clause
: Node_Id
);
4284 -- Similar to Analyze_Package_Name but iterates over all the names
4287 --------------------------
4288 -- Analyze_Package_Name --
4289 --------------------------
4291 procedure Analyze_Package_Name
(Clause
: Node_Id
) is
4292 Pack
: constant Node_Id
:= Name
(Clause
);
4296 pragma Assert
(Nkind
(Clause
) = N_Use_Package_Clause
);
4299 -- Verify that the package standard is not directly named in a
4300 -- use_package_clause.
4302 if Nkind
(Parent
(Clause
)) = N_Compilation_Unit
4303 and then Nkind
(Pack
) = N_Expanded_Name
4305 Pref
:= Prefix
(Pack
);
4307 while Nkind
(Pref
) = N_Expanded_Name
loop
4308 Pref
:= Prefix
(Pref
);
4311 if Entity
(Pref
) = Standard_Standard
then
4313 ("predefined package Standard cannot appear in a context "
4317 end Analyze_Package_Name
;
4319 -------------------------------
4320 -- Analyze_Package_Name_List --
4321 -------------------------------
4323 procedure Analyze_Package_Name_List
(Head_Clause
: Node_Id
) is
4327 -- Due to the way source use clauses are split during parsing we are
4328 -- forced to simply iterate through all entities in scope until the
4329 -- clause representing the last name in the list is found.
4331 Curr
:= Head_Clause
;
4332 while Present
(Curr
) loop
4333 Analyze_Package_Name
(Curr
);
4335 -- Stop iterating over the names in the use clause when we are at
4338 exit when not More_Ids
(Curr
) and then Prev_Ids
(Curr
);
4341 end Analyze_Package_Name_List
;
4347 -- Start of processing for Analyze_Use_Package
4350 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
4352 -- Use clause not allowed in a spec of a predefined package declaration
4353 -- except that packages whose file name starts a-n are OK (these are
4354 -- children of Ada.Numerics, which are never loaded by Rtsfind).
4356 if Is_Predefined_Unit
(Current_Sem_Unit
)
4357 and then Get_Name_String
4358 (Unit_File_Name
(Current_Sem_Unit
)) (1 .. 3) /= "a-n"
4359 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
4360 N_Package_Declaration
4362 Error_Msg_N
("use clause not allowed in predefined spec", N
);
4365 -- Loop through all package names from the original use clause in
4366 -- order to analyze referenced packages. A use_package_clause with only
4367 -- one name does not have More_Ids or Prev_Ids set, while a clause with
4368 -- More_Ids only starts the chain produced by the parser.
4370 if not More_Ids
(N
) and then not Prev_Ids
(N
) then
4371 Analyze_Package_Name
(N
);
4373 elsif More_Ids
(N
) and then not Prev_Ids
(N
) then
4374 Analyze_Package_Name_List
(N
);
4377 if not Is_Entity_Name
(Name
(N
)) then
4378 Error_Msg_N
("& is not a package", Name
(N
));
4384 Chain_Use_Clause
(N
);
4387 Pack
:= Entity
(Name
(N
));
4389 -- There are many cases where scopes are manipulated during analysis, so
4390 -- check that Pack's current use clause has not already been chained
4391 -- before setting its previous use clause.
4393 if Ekind
(Pack
) = E_Package
4394 and then Present
(Current_Use_Clause
(Pack
))
4395 and then Current_Use_Clause
(Pack
) /= N
4396 and then No
(Prev_Use_Clause
(N
))
4397 and then Prev_Use_Clause
(Current_Use_Clause
(Pack
)) /= N
4399 Set_Prev_Use_Clause
(N
, Current_Use_Clause
(Pack
));
4402 -- Mark all entities as potentially use visible
4404 if Ekind
(Pack
) /= E_Package
and then Etype
(Pack
) /= Any_Type
then
4405 if Ekind
(Pack
) = E_Generic_Package
then
4406 Error_Msg_N
-- CODEFIX
4407 ("a generic package is not allowed in a use clause", Name
(N
));
4409 elsif Is_Generic_Subprogram
(Pack
) then
4410 Error_Msg_N
-- CODEFIX
4411 ("a generic subprogram is not allowed in a use clause",
4414 elsif Is_Subprogram
(Pack
) then
4415 Error_Msg_N
-- CODEFIX
4416 ("a subprogram is not allowed in a use clause", Name
(N
));
4419 Error_Msg_N
("& is not allowed in a use clause", Name
(N
));
4423 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4424 Check_In_Previous_With_Clause
(N
, Name
(N
));
4427 Use_One_Package
(N
, Name
(N
));
4430 Mark_Ghost_Clause
(N
);
4431 end Analyze_Use_Package
;
4433 ----------------------
4434 -- Analyze_Use_Type --
4435 ----------------------
4437 procedure Analyze_Use_Type
(N
: Node_Id
; Chain
: Boolean := True) is
4442 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
4444 -- Chain clause to list of use clauses in current scope when flagged
4447 Chain_Use_Clause
(N
);
4450 -- Obtain the base type of the type denoted within the use_type_clause's
4453 Id
:= Subtype_Mark
(N
);
4455 E
:= Base_Type
(Entity
(Id
));
4457 -- There are many cases where a use_type_clause may be reanalyzed due to
4458 -- manipulation of the scope stack so we much guard against those cases
4459 -- here, otherwise, we must add the new use_type_clause to the previous
4460 -- use_type_clause chain in order to mark redundant use_type_clauses as
4461 -- used. When the redundant use-type clauses appear in a parent unit and
4462 -- a child unit we must prevent a circularity in the chain that would
4463 -- otherwise result from the separate steps of analysis and installation
4464 -- of the parent context.
4466 if Present
(Current_Use_Clause
(E
))
4467 and then Current_Use_Clause
(E
) /= N
4468 and then Prev_Use_Clause
(Current_Use_Clause
(E
)) /= N
4469 and then No
(Prev_Use_Clause
(N
))
4471 Set_Prev_Use_Clause
(N
, Current_Use_Clause
(E
));
4474 -- If the Used_Operations list is already initialized, the clause has
4475 -- been analyzed previously, and it is being reinstalled, for example
4476 -- when the clause appears in a package spec and we are compiling the
4477 -- corresponding package body. In that case, make the entities on the
4478 -- existing list use_visible, and mark the corresponding types In_Use.
4480 if Present
(Used_Operations
(N
)) then
4485 Use_One_Type
(Subtype_Mark
(N
), Installed
=> True);
4487 Elmt
:= First_Elmt
(Used_Operations
(N
));
4488 while Present
(Elmt
) loop
4489 Set_Is_Potentially_Use_Visible
(Node
(Elmt
));
4497 -- Otherwise, create new list and attach to it the operations that are
4498 -- made use-visible by the clause.
4500 Set_Used_Operations
(N
, New_Elmt_List
);
4503 if E
/= Any_Type
then
4506 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4507 if Nkind
(Id
) = N_Identifier
then
4508 Error_Msg_N
("type is not directly visible", Id
);
4510 elsif Is_Child_Unit
(Scope
(E
))
4511 and then Scope
(E
) /= System_Aux_Id
4513 Check_In_Previous_With_Clause
(N
, Prefix
(Id
));
4518 -- If the use_type_clause appears in a compilation unit context,
4519 -- check whether it comes from a unit that may appear in a
4520 -- limited_with_clause, for a better error message.
4522 if Nkind
(Parent
(N
)) = N_Compilation_Unit
4523 and then Nkind
(Id
) /= N_Identifier
4529 function Mentioned
(Nam
: Node_Id
) return Boolean;
4530 -- Check whether the prefix of expanded name for the type
4531 -- appears in the prefix of some limited_with_clause.
4537 function Mentioned
(Nam
: Node_Id
) return Boolean is
4539 return Nkind
(Name
(Item
)) = N_Selected_Component
4540 and then Chars
(Prefix
(Name
(Item
))) = Chars
(Nam
);
4544 Pref
:= Prefix
(Id
);
4545 Item
:= First
(Context_Items
(Parent
(N
)));
4546 while Present
(Item
) and then Item
/= N
loop
4547 if Nkind
(Item
) = N_With_Clause
4548 and then Limited_Present
(Item
)
4549 and then Mentioned
(Pref
)
4552 (Get_Msg_Id
, "premature usage of incomplete type");
4561 Mark_Ghost_Clause
(N
);
4562 end Analyze_Use_Type
;
4564 ------------------------
4565 -- Attribute_Renaming --
4566 ------------------------
4568 procedure Attribute_Renaming
(N
: Node_Id
) is
4569 Loc
: constant Source_Ptr
:= Sloc
(N
);
4570 Nam
: constant Node_Id
:= Name
(N
);
4571 Spec
: constant Node_Id
:= Specification
(N
);
4572 New_S
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
4573 Aname
: constant Name_Id
:= Attribute_Name
(Nam
);
4575 Form_Num
: Nat
:= 0;
4576 Expr_List
: List_Id
:= No_List
;
4578 Attr_Node
: Node_Id
;
4579 Body_Node
: Node_Id
;
4580 Param_Spec
: Node_Id
;
4583 Generate_Definition
(New_S
);
4585 -- This procedure is called in the context of subprogram renaming, and
4586 -- thus the attribute must be one that is a subprogram. All of those
4587 -- have at least one formal parameter, with the exceptions of the GNAT
4588 -- attribute 'Img, which GNAT treats as renameable.
4590 if Is_Empty_List
(Parameter_Specifications
(Spec
)) then
4591 if Aname
/= Name_Img
then
4593 ("subprogram renaming an attribute must have formals", N
);
4598 Param_Spec
:= First
(Parameter_Specifications
(Spec
));
4599 while Present
(Param_Spec
) loop
4600 Form_Num
:= Form_Num
+ 1;
4602 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
4603 Find_Type
(Parameter_Type
(Param_Spec
));
4605 -- The profile of the new entity denotes the base type (s) of
4606 -- the types given in the specification. For access parameters
4607 -- there are no subtypes involved.
4609 Rewrite
(Parameter_Type
(Param_Spec
),
4611 (Base_Type
(Entity
(Parameter_Type
(Param_Spec
))), Loc
));
4614 if No
(Expr_List
) then
4615 Expr_List
:= New_List
;
4618 Append_To
(Expr_List
,
4619 Make_Identifier
(Loc
,
4620 Chars
=> Chars
(Defining_Identifier
(Param_Spec
))));
4622 -- The expressions in the attribute reference are not freeze
4623 -- points. Neither is the attribute as a whole, see below.
4625 Set_Must_Not_Freeze
(Last
(Expr_List
));
4630 -- Immediate error if too many formals. Other mismatches in number or
4631 -- types of parameters are detected when we analyze the body of the
4632 -- subprogram that we construct.
4634 if Form_Num
> 2 then
4635 Error_Msg_N
("too many formals for attribute", N
);
4637 -- Error if the attribute reference has expressions that look like
4638 -- formal parameters.
4640 elsif Present
(Expressions
(Nam
)) then
4641 Error_Msg_N
("illegal expressions in attribute reference", Nam
);
4643 elsif Aname
in Name_Compose | Name_Exponent | Name_Leading_Part |
4644 Name_Pos | Name_Round | Name_Scaling |
4647 if Nkind
(N
) = N_Subprogram_Renaming_Declaration
4648 and then Present
(Corresponding_Formal_Spec
(N
))
4651 ("generic actual cannot be attribute involving universal type",
4655 ("attribute involving a universal type cannot be renamed",
4660 -- Rewrite attribute node to have a list of expressions corresponding to
4661 -- the subprogram formals. A renaming declaration is not a freeze point,
4662 -- and the analysis of the attribute reference should not freeze the
4663 -- type of the prefix. We use the original node in the renaming so that
4664 -- its source location is preserved, and checks on stream attributes are
4665 -- properly applied.
4667 Attr_Node
:= Relocate_Node
(Nam
);
4668 Set_Expressions
(Attr_Node
, Expr_List
);
4670 Set_Must_Not_Freeze
(Attr_Node
);
4671 Set_Must_Not_Freeze
(Prefix
(Nam
));
4673 -- Case of renaming a function
4675 if Nkind
(Spec
) = N_Function_Specification
then
4676 if Is_Procedure_Attribute_Name
(Aname
) then
4677 Error_Msg_N
("attribute can only be renamed as procedure", Nam
);
4681 Find_Type
(Result_Definition
(Spec
));
4682 Rewrite
(Result_Definition
(Spec
),
4684 (Base_Type
(Entity
(Result_Definition
(Spec
))), Loc
));
4687 Make_Subprogram_Body
(Loc
,
4688 Specification
=> Spec
,
4689 Declarations
=> New_List
,
4690 Handled_Statement_Sequence
=>
4691 Make_Handled_Sequence_Of_Statements
(Loc
,
4692 Statements
=> New_List
(
4693 Make_Simple_Return_Statement
(Loc
,
4694 Expression
=> Attr_Node
))));
4696 -- Case of renaming a procedure
4699 if not Is_Procedure_Attribute_Name
(Aname
) then
4700 Error_Msg_N
("attribute can only be renamed as function", Nam
);
4705 Make_Subprogram_Body
(Loc
,
4706 Specification
=> Spec
,
4707 Declarations
=> New_List
,
4708 Handled_Statement_Sequence
=>
4709 Make_Handled_Sequence_Of_Statements
(Loc
,
4710 Statements
=> New_List
(Attr_Node
)));
4713 -- Signal the ABE mechanism that the generated subprogram body has not
4714 -- ABE ramifications.
4716 Set_Was_Attribute_Reference
(Body_Node
);
4718 -- In case of tagged types we add the body of the generated function to
4719 -- the freezing actions of the type (because in the general case such
4720 -- type is still not frozen). We exclude from this processing generic
4721 -- formal subprograms found in instantiations.
4723 -- We must exclude restricted run-time libraries because
4724 -- entity AST_Handler is defined in package System.Aux_Dec which is not
4725 -- available in those platforms. Note that we cannot use the function
4726 -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because
4727 -- the ZFP run-time library is not defined as a profile, and we do not
4728 -- want to deal with AST_Handler in ZFP mode.
4730 if not Configurable_Run_Time_Mode
4731 and then No
(Corresponding_Formal_Spec
(N
))
4732 and then not Is_RTE
(Etype
(Nam
), RE_AST_Handler
)
4735 P
: constant Node_Id
:= Prefix
(Nam
);
4738 -- The prefix of 'Img is an object that is evaluated for each call
4739 -- of the function that renames it.
4741 if Aname
= Name_Img
then
4742 Preanalyze_And_Resolve
(P
);
4744 -- For all other attribute renamings, the prefix is a subtype
4750 -- If the target type is not yet frozen, add the body to the
4751 -- actions to be elaborated at freeze time.
4753 if Is_Tagged_Type
(Etype
(P
))
4754 and then In_Open_Scopes
(Scope
(Etype
(P
)))
4756 Append_Freeze_Action
(Etype
(P
), Body_Node
);
4758 Rewrite
(N
, Body_Node
);
4760 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
4764 -- Generic formal subprograms or AST_Handler renaming
4767 Rewrite
(N
, Body_Node
);
4769 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
4772 if Is_Compilation_Unit
(New_S
) then
4774 ("a library unit can only rename another library unit", N
);
4777 -- We suppress elaboration warnings for the resulting entity, since
4778 -- clearly they are not needed, and more particularly, in the case
4779 -- of a generic formal subprogram, the resulting entity can appear
4780 -- after the instantiation itself, and thus look like a bogus case
4781 -- of access before elaboration.
4783 if Legacy_Elaboration_Checks
then
4784 Set_Suppress_Elaboration_Warnings
(New_S
);
4786 end Attribute_Renaming
;
4788 ----------------------
4789 -- Chain_Use_Clause --
4790 ----------------------
4792 procedure Chain_Use_Clause
(N
: Node_Id
) is
4793 Level
: Int
:= Scope_Stack
.Last
;
4799 if not Is_Compilation_Unit
(Current_Scope
)
4800 or else not Is_Child_Unit
(Current_Scope
)
4804 -- Common case for compilation unit
4806 elsif Defining_Entity
(Parent
(N
)) = Current_Scope
then
4810 -- If declaration appears in some other scope, it must be in some
4811 -- parent unit when compiling a child.
4813 Pack
:= Defining_Entity
(Parent
(N
));
4815 if not In_Open_Scopes
(Pack
) then
4818 -- If the use clause appears in an ancestor and we are in the
4819 -- private part of the immediate parent, the use clauses are
4820 -- already installed.
4822 elsif Pack
/= Scope
(Current_Scope
)
4823 and then In_Private_Part
(Scope
(Current_Scope
))
4828 -- Find entry for parent unit in scope stack
4830 while Scope_Stack
.Table
(Level
).Entity
/= Pack
loop
4836 Set_Next_Use_Clause
(N
,
4837 Scope_Stack
.Table
(Level
).First_Use_Clause
);
4838 Scope_Stack
.Table
(Level
).First_Use_Clause
:= N
;
4839 end Chain_Use_Clause
;
4841 ---------------------------
4842 -- Check_Frozen_Renaming --
4843 ---------------------------
4845 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
) is
4850 if Is_Frozen
(Subp
) and then not Has_Completion
(Subp
) then
4853 (Parent
(Declaration_Node
(Subp
)), Defining_Entity
(N
));
4855 if Is_Entity_Name
(Name
(N
)) then
4856 Old_S
:= Entity
(Name
(N
));
4858 if not Is_Frozen
(Old_S
)
4859 and then Operating_Mode
/= Check_Semantics
4861 Append_Freeze_Action
(Old_S
, B_Node
);
4863 Insert_After
(N
, B_Node
);
4867 if Is_Intrinsic_Subprogram
(Old_S
)
4868 and then not In_Instance
4869 and then not Relaxed_RM_Semantics
4872 ("subprogram used in renaming_as_body cannot be intrinsic",
4877 Insert_After
(N
, B_Node
);
4881 end Check_Frozen_Renaming
;
4883 -------------------------------
4884 -- Set_Entity_Or_Discriminal --
4885 -------------------------------
4887 procedure Set_Entity_Or_Discriminal
(N
: Node_Id
; E
: Entity_Id
) is
4891 -- If the entity is not a discriminant, or else expansion is disabled,
4892 -- simply set the entity.
4894 if not In_Spec_Expression
4895 or else Ekind
(E
) /= E_Discriminant
4896 or else Inside_A_Generic
4898 Set_Entity_With_Checks
(N
, E
);
4900 -- The replacement of a discriminant by the corresponding discriminal
4901 -- is not done for a task discriminant that appears in a default
4902 -- expression of an entry parameter. See Exp_Ch2.Expand_Discriminant
4903 -- for details on their handling.
4905 elsif Is_Concurrent_Type
(Scope
(E
)) then
4908 and then Nkind
(P
) not in
4909 N_Parameter_Specification | N_Component_Declaration
4915 and then Nkind
(P
) = N_Parameter_Specification
4919 -- Don't replace a non-qualified discriminant in strict preanalysis
4920 -- mode since it can lead to errors during full analysis when the
4921 -- discriminant gets referenced later.
4923 -- This can occur in situations where a protected type contains
4924 -- an expression function which references a non-prefixed
4928 and then Preanalysis_Active
4929 and then Inside_Preanalysis_Without_Freezing
= 0
4934 Set_Entity
(N
, Discriminal
(E
));
4937 -- Otherwise, this is a discriminant in a context in which
4938 -- it is a reference to the corresponding parameter of the
4939 -- init proc for the enclosing type.
4942 Set_Entity
(N
, Discriminal
(E
));
4944 end Set_Entity_Or_Discriminal
;
4946 -----------------------------------
4947 -- Check_In_Previous_With_Clause --
4948 -----------------------------------
4950 procedure Check_In_Previous_With_Clause
(N
, Nam
: Node_Id
) is
4951 Pack
: constant Entity_Id
:= Entity
(Original_Node
(Nam
));
4956 Item
:= First
(Context_Items
(Parent
(N
)));
4957 while Present
(Item
) and then Item
/= N
loop
4958 if Nkind
(Item
) = N_With_Clause
4960 -- Protect the frontend against previous critical errors
4962 and then Nkind
(Name
(Item
)) /= N_Selected_Component
4963 and then Entity
(Name
(Item
)) = Pack
4967 -- Find root library unit in with_clause
4969 while Nkind
(Par
) = N_Expanded_Name
loop
4970 Par
:= Prefix
(Par
);
4973 if Is_Child_Unit
(Entity
(Original_Node
(Par
))) then
4974 Error_Msg_NE
("& is not directly visible", Par
, Entity
(Par
));
4983 -- On exit, package is not mentioned in a previous with_clause.
4984 -- Check if its prefix is.
4986 if Nkind
(Nam
) = N_Expanded_Name
then
4987 Check_In_Previous_With_Clause
(N
, Prefix
(Nam
));
4989 elsif Pack
/= Any_Id
then
4990 Error_Msg_NE
("& is not visible", Nam
, Pack
);
4992 end Check_In_Previous_With_Clause
;
4994 ---------------------------------
4995 -- Check_Library_Unit_Renaming --
4996 ---------------------------------
4998 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
) is
5002 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5005 -- Check for library unit. Note that we used to check for the scope
5006 -- being Standard here, but that was wrong for Standard itself.
5008 elsif not Is_Compilation_Unit
(Old_E
)
5009 and then not Is_Child_Unit
(Old_E
)
5011 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
5013 -- Entities defined in Standard (operators and boolean literals) cannot
5014 -- be renamed as library units.
5016 elsif Scope
(Old_E
) = Standard_Standard
5017 and then Sloc
(Old_E
) = Standard_Location
5019 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
5021 elsif Present
(Parent_Spec
(N
))
5022 and then Nkind
(Unit
(Parent_Spec
(N
))) = N_Generic_Package_Declaration
5023 and then not Is_Child_Unit
(Old_E
)
5026 ("renamed unit must be a child unit of generic parent", Name
(N
));
5028 elsif Nkind
(N
) in N_Generic_Renaming_Declaration
5029 and then Nkind
(Name
(N
)) = N_Expanded_Name
5030 and then Is_Generic_Instance
(Entity
(Prefix
(Name
(N
))))
5031 and then Is_Generic_Unit
(Old_E
)
5034 ("renamed generic unit must be a library unit", Name
(N
));
5036 elsif Is_Package_Or_Generic_Package
(Old_E
) then
5038 -- Inherit categorization flags
5040 New_E
:= Defining_Entity
(N
);
5041 Set_Is_Pure
(New_E
, Is_Pure
(Old_E
));
5042 Set_Is_Preelaborated
(New_E
, Is_Preelaborated
(Old_E
));
5043 Set_Is_Remote_Call_Interface
(New_E
,
5044 Is_Remote_Call_Interface
(Old_E
));
5045 Set_Is_Remote_Types
(New_E
, Is_Remote_Types
(Old_E
));
5046 Set_Is_Shared_Passive
(New_E
, Is_Shared_Passive
(Old_E
));
5048 end Check_Library_Unit_Renaming
;
5050 ------------------------
5051 -- Enclosing_Instance --
5052 ------------------------
5054 function Enclosing_Instance
return Entity_Id
is
5058 if not Is_Generic_Instance
(Current_Scope
) then
5062 S
:= Scope
(Current_Scope
);
5063 while S
/= Standard_Standard
loop
5064 if Is_Generic_Instance
(S
) then
5072 end Enclosing_Instance
;
5078 procedure End_Scope
is
5084 Id
:= First_Entity
(Current_Scope
);
5085 while Present
(Id
) loop
5086 -- An entity in the current scope is not necessarily the first one
5087 -- on its homonym chain. Find its predecessor if any,
5088 -- If it is an internal entity, it will not be in the visibility
5089 -- chain altogether, and there is nothing to unchain.
5091 if Id
/= Current_Entity
(Id
) then
5092 Prev
:= Current_Entity
(Id
);
5093 while Present
(Prev
)
5094 and then Homonym
(Prev
) /= Id
5096 Prev
:= Homonym
(Prev
);
5099 -- Skip to end of loop if Id is not in the visibility chain
5109 Set_Is_Immediately_Visible
(Id
, False);
5111 Outer
:= Homonym
(Id
);
5112 while Present
(Outer
) and then Scope
(Outer
) = Current_Scope
loop
5113 Outer
:= Homonym
(Outer
);
5116 -- Reset homonym link of other entities, but do not modify link
5117 -- between entities in current scope, so that the back-end can have
5118 -- a proper count of local overloadings.
5121 Set_Name_Entity_Id
(Chars
(Id
), Outer
);
5123 elsif Scope
(Prev
) /= Scope
(Id
) then
5124 Set_Homonym
(Prev
, Outer
);
5131 -- If the scope generated freeze actions, place them before the
5132 -- current declaration and analyze them. Type declarations and
5133 -- the bodies of initialization procedures can generate such nodes.
5134 -- We follow the parent chain until we reach a list node, which is
5135 -- the enclosing list of declarations. If the list appears within
5136 -- a protected definition, move freeze nodes outside the protected
5140 (Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
)
5144 L
: constant List_Id
:= Scope_Stack
.Table
5145 (Scope_Stack
.Last
).Pending_Freeze_Actions
;
5148 if Is_Itype
(Current_Scope
) then
5149 Decl
:= Associated_Node_For_Itype
(Current_Scope
);
5151 Decl
:= Parent
(Current_Scope
);
5156 while not Is_List_Member
(Decl
)
5157 or else Nkind
(Parent
(Decl
)) in N_Protected_Definition
5160 Decl
:= Parent
(Decl
);
5163 Insert_List_Before_And_Analyze
(Decl
, L
);
5171 ---------------------
5172 -- End_Use_Clauses --
5173 ---------------------
5175 procedure End_Use_Clauses
(Clause
: Node_Id
) is
5179 -- Remove use_type_clauses first, because they affect the visibility of
5180 -- operators in subsequent used packages.
5183 while Present
(U
) loop
5184 if Nkind
(U
) = N_Use_Type_Clause
then
5188 Next_Use_Clause
(U
);
5192 while Present
(U
) loop
5193 if Nkind
(U
) = N_Use_Package_Clause
then
5194 End_Use_Package
(U
);
5197 Next_Use_Clause
(U
);
5199 end End_Use_Clauses
;
5201 ---------------------
5202 -- End_Use_Package --
5203 ---------------------
5205 procedure End_Use_Package
(N
: Node_Id
) is
5207 Pack_Name
: Node_Id
;
5211 function Is_Primitive_Operator_In_Use
5213 F
: Entity_Id
) return Boolean;
5214 -- Check whether Op is a primitive operator of a use-visible type
5216 ----------------------------------
5217 -- Is_Primitive_Operator_In_Use --
5218 ----------------------------------
5220 function Is_Primitive_Operator_In_Use
5222 F
: Entity_Id
) return Boolean
5224 T
: constant Entity_Id
:= Base_Type
(Etype
(F
));
5226 return In_Use
(T
) and then Scope
(T
) = Scope
(Op
);
5227 end Is_Primitive_Operator_In_Use
;
5229 -- Start of processing for End_Use_Package
5232 Pack_Name
:= Name
(N
);
5234 -- Test that Pack_Name actually denotes a package before processing
5236 if Is_Entity_Name
(Pack_Name
)
5237 and then Ekind
(Entity
(Pack_Name
)) = E_Package
5239 Pack
:= Entity
(Pack_Name
);
5241 if In_Open_Scopes
(Pack
) then
5244 elsif not Redundant_Use
(Pack_Name
) then
5245 Set_In_Use
(Pack
, False);
5246 Set_Current_Use_Clause
(Pack
, Empty
);
5248 Id
:= First_Entity
(Pack
);
5249 while Present
(Id
) loop
5251 -- Preserve use-visibility of operators that are primitive
5252 -- operators of a type that is use-visible through an active
5255 if Nkind
(Id
) = N_Defining_Operator_Symbol
5257 (Is_Primitive_Operator_In_Use
(Id
, First_Formal
(Id
))
5259 (Present
(Next_Formal
(First_Formal
(Id
)))
5261 Is_Primitive_Operator_In_Use
5262 (Id
, Next_Formal
(First_Formal
(Id
)))))
5266 Set_Is_Potentially_Use_Visible
(Id
, False);
5269 if Is_Private_Type
(Id
)
5270 and then Present
(Full_View
(Id
))
5272 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
5278 if Present
(Renamed_Entity
(Pack
)) then
5279 Set_In_Use
(Renamed_Entity
(Pack
), False);
5280 Set_Current_Use_Clause
(Renamed_Entity
(Pack
), Empty
);
5283 if Chars
(Pack
) = Name_System
5284 and then Scope
(Pack
) = Standard_Standard
5285 and then Present_System_Aux
5287 Id
:= First_Entity
(System_Aux_Id
);
5288 while Present
(Id
) loop
5289 Set_Is_Potentially_Use_Visible
(Id
, False);
5291 if Is_Private_Type
(Id
)
5292 and then Present
(Full_View
(Id
))
5294 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
5300 Set_In_Use
(System_Aux_Id
, False);
5303 Set_Redundant_Use
(Pack_Name
, False);
5307 if Present
(Hidden_By_Use_Clause
(N
)) then
5308 Elmt
:= First_Elmt
(Hidden_By_Use_Clause
(N
));
5309 while Present
(Elmt
) loop
5311 E
: constant Entity_Id
:= Node
(Elmt
);
5314 -- Reset either Use_Visibility or Direct_Visibility, depending
5315 -- on how the entity was hidden by the use clause.
5317 if In_Use
(Scope
(E
))
5318 and then Used_As_Generic_Actual
(Scope
(E
))
5320 Set_Is_Potentially_Use_Visible
(Node
(Elmt
));
5322 Set_Is_Immediately_Visible
(Node
(Elmt
));
5329 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
5331 end End_Use_Package
;
5337 procedure End_Use_Type
(N
: Node_Id
) is
5342 -- Start of processing for End_Use_Type
5345 Id
:= Subtype_Mark
(N
);
5347 -- A call to Rtsfind may occur while analyzing a use_type_clause, in
5348 -- which case the type marks are not resolved yet, so guard against that
5351 if Is_Entity_Name
(Id
) and then Present
(Entity
(Id
)) then
5354 if T
= Any_Type
or else From_Limited_With
(T
) then
5357 -- Note that the use_type_clause may mention a subtype of the type
5358 -- whose primitive operations have been made visible. Here as
5359 -- elsewhere, it is the base type that matters for visibility.
5361 elsif In_Open_Scopes
(Scope
(Base_Type
(T
))) then
5364 elsif not Redundant_Use
(Id
) then
5365 Set_In_Use
(T
, False);
5366 Set_In_Use
(Base_Type
(T
), False);
5367 Set_Current_Use_Clause
(T
, Empty
);
5368 Set_Current_Use_Clause
(Base_Type
(T
), Empty
);
5370 -- See Use_One_Type for the rationale. This is a bit on the naive
5371 -- side, but should be good enough in practice.
5373 if Is_Tagged_Type
(T
) then
5374 Set_In_Use
(Class_Wide_Type
(T
), False);
5379 if Is_Empty_Elmt_List
(Used_Operations
(N
)) then
5383 Elmt
:= First_Elmt
(Used_Operations
(N
));
5384 while Present
(Elmt
) loop
5385 Set_Is_Potentially_Use_Visible
(Node
(Elmt
), False);
5391 --------------------
5392 -- Entity_Of_Unit --
5393 --------------------
5395 function Entity_Of_Unit
(U
: Node_Id
) return Entity_Id
is
5397 if Nkind
(U
) = N_Package_Instantiation
and then Analyzed
(U
) then
5398 return Defining_Entity
(Instance_Spec
(U
));
5400 return Defining_Entity
(U
);
5404 --------------------------------------
5405 -- Error_Missing_With_Of_Known_Unit --
5406 --------------------------------------
5408 procedure Error_Missing_With_Of_Known_Unit
(Pkg
: Node_Id
) is
5409 Selectors
: array (1 .. 6) of Node_Id
;
5410 -- Contains the chars of the full package name up to maximum number
5411 -- allowed as per Errout.Error_Msg_Name_# variables.
5413 Count
: Integer := Selectors
'First;
5414 -- Count of selector names forming the full package name
5416 Current_Pkg
: Node_Id
:= Parent
(Pkg
);
5419 Selectors
(Count
) := Pkg
;
5421 -- Gather all the selectors we can display
5423 while Nkind
(Current_Pkg
) = N_Selected_Component
5424 and then Is_Known_Unit
(Current_Pkg
)
5425 and then Count
< Selectors
'Length
5428 Selectors
(Count
) := Selector_Name
(Current_Pkg
);
5429 Current_Pkg
:= Parent
(Current_Pkg
);
5432 -- Display the error message based on the number of selectors found
5436 Error_Msg_Node_1
:= Selectors
(1);
5437 Error_Msg_N
-- CODEFIX
5438 ("\\missing `WITH &;`", Pkg
);
5440 Error_Msg_Node_1
:= Selectors
(1);
5441 Error_Msg_Node_2
:= Selectors
(2);
5442 Error_Msg_N
-- CODEFIX
5443 ("\\missing `WITH &.&;`", Pkg
);
5445 Error_Msg_Node_1
:= Selectors
(1);
5446 Error_Msg_Node_2
:= Selectors
(2);
5447 Error_Msg_Node_3
:= Selectors
(3);
5448 Error_Msg_N
-- CODEFIX
5449 ("\\missing `WITH &.&.&;`", Pkg
);
5451 Error_Msg_Node_1
:= Selectors
(1);
5452 Error_Msg_Node_2
:= Selectors
(2);
5453 Error_Msg_Node_3
:= Selectors
(3);
5454 Error_Msg_Node_3
:= Selectors
(4);
5455 Error_Msg_N
-- CODEFIX
5456 ("\\missing `WITH &.&.&.&;`", Pkg
);
5458 Error_Msg_Node_1
:= Selectors
(1);
5459 Error_Msg_Node_2
:= Selectors
(2);
5460 Error_Msg_Node_3
:= Selectors
(3);
5461 Error_Msg_Node_3
:= Selectors
(4);
5462 Error_Msg_Node_3
:= Selectors
(5);
5463 Error_Msg_N
-- CODEFIX
5464 ("\\missing `WITH &.&.&.&.&;`", Pkg
);
5466 Error_Msg_Node_1
:= Selectors
(1);
5467 Error_Msg_Node_2
:= Selectors
(2);
5468 Error_Msg_Node_3
:= Selectors
(3);
5469 Error_Msg_Node_4
:= Selectors
(4);
5470 Error_Msg_Node_5
:= Selectors
(5);
5471 Error_Msg_Node_6
:= Selectors
(6);
5472 Error_Msg_N
-- CODEFIX
5473 ("\\missing `WITH &.&.&.&.&.&;`", Pkg
);
5475 raise Program_Error
;
5477 end Error_Missing_With_Of_Known_Unit
;
5479 --------------------
5480 -- Is_Self_Hidden --
5481 --------------------
5483 function Is_Self_Hidden
(E
: Entity_Id
) return Boolean is
5485 if Is_Not_Self_Hidden
(E
) then
5486 return Ekind
(E
) = E_Void
;
5492 ----------------------
5493 -- Find_Direct_Name --
5494 ----------------------
5496 procedure Find_Direct_Name
(N
: Node_Id
) is
5501 Homonyms
: Entity_Id
;
5502 -- Saves start of homonym chain
5504 Inst
: Entity_Id
:= Empty
;
5505 -- Enclosing instance, if any
5507 Nvis_Entity
: Boolean;
5508 -- Set True to indicate that there is at least one entity on the homonym
5509 -- chain which, while not visible, is visible enough from the user point
5510 -- of view to warrant an error message of "not visible" rather than
5513 Nvis_Is_Private_Subprg
: Boolean := False;
5514 -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais
5515 -- effect concerning library subprograms has been detected. Used to
5516 -- generate the precise error message.
5518 function From_Actual_Package
(E
: Entity_Id
) return Boolean;
5519 -- Returns true if the entity is an actual for a package that is itself
5520 -- an actual for a formal package of the current instance. Such an
5521 -- entity requires special handling because it may be use-visible but
5522 -- hides directly visible entities defined outside the instance, because
5523 -- the corresponding formal did so in the generic.
5525 function Is_Actual_Parameter
return Boolean;
5526 -- This function checks if the node N is an identifier that is an actual
5527 -- parameter of a procedure call. If so it returns True, otherwise it
5528 -- return False. The reason for this check is that at this stage we do
5529 -- not know what procedure is being called if the procedure might be
5530 -- overloaded, so it is premature to go setting referenced flags or
5531 -- making calls to Generate_Reference. We will wait till Resolve_Actuals
5532 -- for that processing.
5533 -- Note: there is a similar routine Sem_Util.Is_Actual_Parameter, but
5534 -- it works for both function and procedure calls, while here we are
5535 -- only concerned with procedure calls (and with entry calls as well,
5536 -- but they are parsed as procedure calls and only later rewritten to
5539 function Known_But_Invisible
(E
: Entity_Id
) return Boolean;
5540 -- This function determines whether a reference to the entity E, which
5541 -- is not visible, can reasonably be considered to be known to the
5542 -- writer of the reference. This is a heuristic test, used only for
5543 -- the purposes of figuring out whether we prefer to complain that an
5544 -- entity is undefined or invisible (and identify the declaration of
5545 -- the invisible entity in the latter case). The point here is that we
5546 -- don't want to complain that something is invisible and then point to
5547 -- something entirely mysterious to the writer.
5549 procedure Nvis_Messages
;
5550 -- Called if there are no visible entries for N, but there is at least
5551 -- one non-directly visible, or hidden declaration. This procedure
5552 -- outputs an appropriate set of error messages.
5554 procedure Undefined
(Nvis
: Boolean);
5555 -- This function is called if the current node has no corresponding
5556 -- visible entity or entities. The value set in Msg indicates whether
5557 -- an error message was generated (multiple error messages for the
5558 -- same variable are generally suppressed, see body for details).
5559 -- Msg is True if an error message was generated, False if not. This
5560 -- value is used by the caller to determine whether or not to output
5561 -- additional messages where appropriate. The parameter is set False
5562 -- to get the message "X is undefined", and True to get the message
5563 -- "X is not visible".
5565 -------------------------
5566 -- From_Actual_Package --
5567 -------------------------
5569 function From_Actual_Package
(E
: Entity_Id
) return Boolean is
5570 Scop
: constant Entity_Id
:= Scope
(E
);
5571 -- Declared scope of candidate entity
5573 function Declared_In_Actual
(Pack
: Entity_Id
) return Boolean;
5574 -- Recursive function that does the work and examines actuals of
5575 -- actual packages of current instance.
5577 ------------------------
5578 -- Declared_In_Actual --
5579 ------------------------
5581 function Declared_In_Actual
(Pack
: Entity_Id
) return Boolean is
5582 pragma Assert
(Ekind
(Pack
) = E_Package
);
5585 if No
(Associated_Formal_Package
(Pack
)) then
5589 Act
:= First_Entity
(Pack
);
5590 while Present
(Act
) loop
5591 if Renamed_Entity
(Pack
) = Scop
then
5594 -- Check for end of list of actuals
5596 elsif Ekind
(Act
) = E_Package
5597 and then Renamed_Entity
(Act
) = Pack
5601 elsif Ekind
(Act
) = E_Package
5602 and then Declared_In_Actual
(Act
)
5612 end Declared_In_Actual
;
5618 -- Start of processing for From_Actual_Package
5621 if not In_Instance
then
5625 Inst
:= Current_Scope
;
5626 while Present
(Inst
)
5627 and then Ekind
(Inst
) /= E_Package
5628 and then not Is_Generic_Instance
(Inst
)
5630 Inst
:= Scope
(Inst
);
5637 Act
:= First_Entity
(Inst
);
5638 while Present
(Act
) loop
5639 if Ekind
(Act
) = E_Package
5640 and then Declared_In_Actual
(Act
)
5650 end From_Actual_Package
;
5652 -------------------------
5653 -- Is_Actual_Parameter --
5654 -------------------------
5656 function Is_Actual_Parameter
return Boolean is
5658 if Nkind
(N
) = N_Identifier
then
5659 case Nkind
(Parent
(N
)) is
5660 when N_Procedure_Call_Statement
=>
5661 return Is_List_Member
(N
)
5662 and then List_Containing
(N
) =
5663 Parameter_Associations
(Parent
(N
));
5665 when N_Parameter_Association
=>
5666 return N
= Explicit_Actual_Parameter
(Parent
(N
))
5667 and then Nkind
(Parent
(Parent
(N
))) =
5668 N_Procedure_Call_Statement
;
5676 end Is_Actual_Parameter
;
5678 -------------------------
5679 -- Known_But_Invisible --
5680 -------------------------
5682 function Known_But_Invisible
(E
: Entity_Id
) return Boolean is
5683 Fname
: File_Name_Type
;
5686 -- Entities in Standard are always considered to be known
5688 if Sloc
(E
) <= Standard_Location
then
5691 -- An entity that does not come from source is always considered
5692 -- to be unknown, since it is an artifact of code expansion.
5694 elsif not Comes_From_Source
(E
) then
5698 -- Here we have an entity that is not from package Standard, and
5699 -- which comes from Source. See if it comes from an internal file.
5701 Fname
:= Unit_File_Name
(Get_Source_Unit
(E
));
5703 -- Case of from internal file
5705 if In_Internal_Unit
(E
) then
5707 -- Private part entities in internal files are never considered
5708 -- to be known to the writer of normal application code.
5710 if Is_Hidden
(E
) then
5714 -- Entities from System packages other than System and
5715 -- System.Storage_Elements are not considered to be known.
5716 -- System.Auxxxx files are also considered known to the user.
5718 -- Should refine this at some point to generally distinguish
5719 -- between known and unknown internal files ???
5721 Get_Name_String
(Fname
);
5726 Name_Buffer
(1 .. 2) /= "s-"
5728 Name_Buffer
(3 .. 8) = "stoele"
5730 Name_Buffer
(3 .. 5) = "aux";
5732 -- If not an internal file, then entity is definitely known, even if
5733 -- it is in a private part (the message generated will note that it
5734 -- is in a private part).
5739 end Known_But_Invisible
;
5745 procedure Nvis_Messages
is
5746 Comp_Unit
: Node_Id
;
5748 Found
: Boolean := False;
5749 Hidden
: Boolean := False;
5753 -- Ada 2005 (AI-262): Generate a precise error concerning the
5754 -- Beaujolais effect that was previously detected
5756 if Nvis_Is_Private_Subprg
then
5758 pragma Assert
(Nkind
(E2
) = N_Defining_Identifier
5759 and then Ekind
(E2
) = E_Function
5760 and then Scope
(E2
) = Standard_Standard
5761 and then Has_Private_With
(E2
));
5763 -- Find the sloc corresponding to the private with'ed unit
5765 Comp_Unit
:= Cunit
(Current_Sem_Unit
);
5766 Error_Msg_Sloc
:= No_Location
;
5768 Item
:= First
(Context_Items
(Comp_Unit
));
5769 while Present
(Item
) loop
5770 if Nkind
(Item
) = N_With_Clause
5771 and then Private_Present
(Item
)
5772 and then Entity
(Name
(Item
)) = E2
5774 Error_Msg_Sloc
:= Sloc
(Item
);
5781 pragma Assert
(Error_Msg_Sloc
/= No_Location
);
5783 Error_Msg_N
("(Ada 2005): hidden by private with clause #", N
);
5787 Undefined
(Nvis
=> True);
5791 -- First loop does hidden declarations
5794 while Present
(Ent
) loop
5795 if Is_Potentially_Use_Visible
(Ent
) then
5797 Error_Msg_N
-- CODEFIX
5798 ("multiple use clauses cause hiding!", N
);
5802 Error_Msg_Sloc
:= Sloc
(Ent
);
5803 Error_Msg_N
-- CODEFIX
5804 ("hidden declaration#!", N
);
5807 Ent
:= Homonym
(Ent
);
5810 -- If we found hidden declarations, then that's enough, don't
5811 -- bother looking for non-visible declarations as well.
5817 -- Second loop does non-directly visible declarations
5820 while Present
(Ent
) loop
5821 if not Is_Potentially_Use_Visible
(Ent
) then
5823 -- Do not bother the user with unknown entities
5825 if not Known_But_Invisible
(Ent
) then
5829 Error_Msg_Sloc
:= Sloc
(Ent
);
5831 -- Output message noting that there is a non-visible
5832 -- declaration, distinguishing the private part case.
5834 if Is_Hidden
(Ent
) then
5835 Error_Msg_N
("non-visible (private) declaration#!", N
);
5837 -- If the entity is declared in a generic package, it
5838 -- cannot be visible, so there is no point in adding it
5839 -- to the list of candidates if another homograph from a
5840 -- non-generic package has been seen.
5842 elsif Ekind
(Scope
(Ent
)) = E_Generic_Package
5848 -- When the entity comes from a generic instance the
5849 -- normal error message machinery will give the line
5850 -- number of the generic package and the location of
5851 -- the generic instance, but not the name of the
5854 -- So, in order to give more descriptive error messages
5855 -- in this case, we include the name of the generic
5858 if Is_Generic_Instance
(Scope
(Ent
)) then
5859 Error_Msg_Name_1
:= Chars
(Scope
(Ent
));
5860 Error_Msg_N
-- CODEFIX
5861 ("non-visible declaration from %#!", N
);
5863 -- Otherwise print the message normally
5866 Error_Msg_N
-- CODEFIX
5867 ("non-visible declaration#!", N
);
5870 if Ekind
(Scope
(Ent
)) /= E_Generic_Package
then
5874 if Is_Compilation_Unit
(Ent
)
5876 Nkind
(Parent
(Parent
(N
))) = N_Use_Package_Clause
5878 Error_Msg_Qual_Level
:= 99;
5879 Error_Msg_NE
-- CODEFIX
5880 ("\\missing `WITH &;`", N
, Ent
);
5881 Error_Msg_Qual_Level
:= 0;
5884 if Ekind
(Ent
) = E_Discriminant
5885 and then Present
(Corresponding_Discriminant
(Ent
))
5886 and then Scope
(Corresponding_Discriminant
(Ent
)) =
5890 ("inherited discriminant not allowed here" &
5891 " (RM 3.8 (12), 3.8.1 (6))!", N
);
5895 -- Set entity and its containing package as referenced. We
5896 -- can't be sure of this, but this seems a better choice
5897 -- to avoid unused entity messages.
5899 if Comes_From_Source
(Ent
) then
5900 Set_Referenced
(Ent
);
5901 Set_Referenced
(Cunit_Entity
(Get_Source_Unit
(Ent
)));
5906 Ent
:= Homonym
(Ent
);
5915 procedure Undefined
(Nvis
: Boolean) is
5916 Emsg
: Error_Msg_Id
;
5919 -- We should never find an undefined internal name. If we do, then
5920 -- see if we have previous errors. If so, ignore on the grounds that
5921 -- it is probably a cascaded message (e.g. a block label from a badly
5922 -- formed block). If no previous errors, then we have a real internal
5923 -- error of some kind so raise an exception.
5925 if Is_Internal_Name
(Chars
(N
)) then
5926 if Total_Errors_Detected
/= 0 then
5929 raise Program_Error
;
5933 -- A very specialized error check, if the undefined variable is
5934 -- a case tag, and the case type is an enumeration type, check
5935 -- for a possible misspelling, and if so, modify the identifier
5937 -- Named aggregate should also be handled similarly ???
5939 if Nkind
(N
) = N_Identifier
5940 and then Nkind
(Parent
(N
)) = N_Case_Statement_Alternative
5943 Case_Stm
: constant Node_Id
:= Parent
(Parent
(N
));
5944 Case_Typ
: constant Entity_Id
:= Etype
(Expression
(Case_Stm
));
5949 if Is_Enumeration_Type
(Case_Typ
)
5950 and then not Is_Standard_Character_Type
(Case_Typ
)
5952 Lit
:= First_Literal
(Case_Typ
);
5953 Get_Name_String
(Chars
(Lit
));
5955 if Chars
(Lit
) /= Chars
(N
)
5956 and then Is_Bad_Spelling_Of
(Chars
(N
), Chars
(Lit
))
5958 Error_Msg_Node_2
:= Lit
;
5959 Error_Msg_N
-- CODEFIX
5960 ("& is undefined, assume misspelling of &", N
);
5961 Rewrite
(N
, New_Occurrence_Of
(Lit
, Sloc
(N
)));
5970 -- Normal processing
5972 Set_Entity
(N
, Any_Id
);
5973 Set_Etype
(N
, Any_Type
);
5975 -- We use the table Urefs to keep track of entities for which we
5976 -- have issued errors for undefined references. Multiple errors
5977 -- for a single name are normally suppressed, however we modify
5978 -- the error message to alert the programmer to this effect.
5980 for J
in Urefs
.First
.. Urefs
.Last
loop
5981 if Chars
(N
) = Chars
(Urefs
.Table
(J
).Node
) then
5982 if Urefs
.Table
(J
).Err
/= No_Error_Msg
5983 and then Sloc
(N
) /= Urefs
.Table
(J
).Loc
5985 Error_Msg_Node_1
:= Urefs
.Table
(J
).Node
;
5987 if Urefs
.Table
(J
).Nvis
then
5988 Change_Error_Text
(Urefs
.Table
(J
).Err
,
5989 "& is not visible (more references follow)");
5991 Change_Error_Text
(Urefs
.Table
(J
).Err
,
5992 "& is undefined (more references follow)");
5995 Urefs
.Table
(J
).Err
:= No_Error_Msg
;
5998 -- Although we will set Msg False, and thus suppress the
5999 -- message, we also set Error_Posted True, to avoid any
6000 -- cascaded messages resulting from the undefined reference.
6003 Set_Error_Posted
(N
);
6008 -- If entry not found, this is first undefined occurrence
6011 Error_Msg_N
("& is not visible!", N
);
6015 Error_Msg_N
("& is undefined!", N
);
6018 -- A very bizarre special check, if the undefined identifier
6019 -- is Put or Put_Line, then add a special error message (since
6020 -- this is a very common error for beginners to make).
6022 if Chars
(N
) in Name_Put | Name_Put_Line
then
6023 Error_Msg_N
-- CODEFIX
6024 ("\\possible missing `WITH Ada.Text_'I'O; " &
6025 "USE Ada.Text_'I'O`!", N
);
6027 -- Another special check if N is the prefix of a selected
6028 -- component which is a known unit: add message complaining
6029 -- about missing with for this unit.
6031 elsif Nkind
(Parent
(N
)) = N_Selected_Component
6032 and then N
= Prefix
(Parent
(N
))
6033 and then Is_Known_Unit
(Parent
(N
))
6035 Error_Missing_With_Of_Known_Unit
(N
);
6038 -- Now check for possible misspellings
6042 Ematch
: Entity_Id
:= Empty
;
6044 for Nam
in First_Name_Id
.. Last_Name_Id
loop
6045 E
:= Get_Name_Entity_Id
(Nam
);
6048 and then (Is_Immediately_Visible
(E
)
6050 Is_Potentially_Use_Visible
(E
))
6052 if Is_Bad_Spelling_Of
(Chars
(N
), Nam
) then
6059 if Present
(Ematch
) then
6060 Error_Msg_NE
-- CODEFIX
6061 ("\possible misspelling of&", N
, Ematch
);
6066 -- Make entry in undefined references table unless the full errors
6067 -- switch is set, in which case by refraining from generating the
6068 -- table entry we guarantee that we get an error message for every
6069 -- undefined reference. The entry is not added if we are ignoring
6072 if not All_Errors_Mode
6073 and then Ignore_Errors_Enable
= 0
6074 and then not Get_Ignore_Errors
6088 Nested_Inst
: Entity_Id
:= Empty
;
6089 -- The entity of a nested instance which appears within Inst (if any)
6091 -- Start of processing for Find_Direct_Name
6094 -- If the entity pointer is already set, this is an internal node, or
6095 -- a node that is analyzed more than once, after a tree modification.
6096 -- In such a case there is no resolution to perform, just set the type.
6098 if Present
(Entity
(N
)) then
6099 if Is_Type
(Entity
(N
)) then
6100 Set_Etype
(N
, Entity
(N
));
6104 Entyp
: constant Entity_Id
:= Etype
(Entity
(N
));
6107 -- One special case here. If the Etype field is already set,
6108 -- and references the packed array type corresponding to the
6109 -- etype of the referenced entity, then leave it alone. This
6110 -- happens for trees generated from Exp_Pakd, where expressions
6111 -- can be deliberately "mis-typed" to the packed array type.
6113 if Is_Packed_Array
(Entyp
)
6114 and then Present
(Etype
(N
))
6115 and then Etype
(N
) = Packed_Array_Impl_Type
(Entyp
)
6119 -- If not that special case, then just reset the Etype
6122 Set_Etype
(N
, Entyp
);
6127 -- Although the marking of use clauses happens at the end of
6128 -- Find_Direct_Name, a certain case where a generic actual satisfies
6129 -- a use clause must be checked here due to how the generic machinery
6130 -- handles the analysis of said actuals.
6133 and then Nkind
(Parent
(N
)) = N_Generic_Association
6135 Mark_Use_Clauses
(Entity
(N
));
6141 -- Preserve relevant elaboration-related attributes of the context which
6142 -- are no longer available or very expensive to recompute once analysis,
6143 -- resolution, and expansion are over.
6145 if Nkind
(N
) = N_Identifier
then
6146 Mark_Elaboration_Attributes
6153 -- Here if Entity pointer was not set, we need full visibility analysis
6154 -- First we generate debugging output if the debug E flag is set.
6156 if Debug_Flag_E
then
6157 Write_Str
("Looking for ");
6158 Write_Name
(Chars
(N
));
6162 Homonyms
:= Current_Entity
(N
);
6163 Nvis_Entity
:= False;
6166 while Present
(E
) loop
6168 -- If entity is immediately visible or potentially use visible, then
6169 -- process the entity and we are done.
6171 if Is_Immediately_Visible
(E
) then
6172 goto Immediately_Visible_Entity
;
6174 elsif Is_Potentially_Use_Visible
(E
) then
6175 goto Potentially_Use_Visible_Entity
;
6177 -- Note if a known but invisible entity encountered
6179 elsif Known_But_Invisible
(E
) then
6180 Nvis_Entity
:= True;
6183 -- Move to next entity in chain and continue search
6188 -- If no entries on homonym chain that were potentially visible,
6189 -- and no entities reasonably considered as non-visible, then
6190 -- we have a plain undefined reference, with no additional
6191 -- explanation required.
6193 if not Nvis_Entity
then
6194 Undefined
(Nvis
=> False);
6196 -- Otherwise there is at least one entry on the homonym chain that
6197 -- is reasonably considered as being known and non-visible.
6205 -- Processing for a potentially use visible entry found. We must search
6206 -- the rest of the homonym chain for two reasons. First, if there is a
6207 -- directly visible entry, then none of the potentially use-visible
6208 -- entities are directly visible (RM 8.4(10)). Second, we need to check
6209 -- for the case of multiple potentially use-visible entries hiding one
6210 -- another and as a result being non-directly visible (RM 8.4(11)).
6212 <<Potentially_Use_Visible_Entity
>> declare
6213 Only_One_Visible
: Boolean := True;
6214 All_Overloadable
: Boolean := Is_Overloadable
(E
);
6218 while Present
(E2
) loop
6219 if Is_Immediately_Visible
(E2
) then
6221 -- If the use-visible entity comes from the actual for a
6222 -- formal package, it hides a directly visible entity from
6223 -- outside the instance.
6225 if From_Actual_Package
(E
)
6226 and then Scope_Depth
(Scope
(E2
)) < Scope_Depth
(Inst
)
6231 goto Immediately_Visible_Entity
;
6234 elsif Is_Potentially_Use_Visible
(E2
) then
6235 Only_One_Visible
:= False;
6236 All_Overloadable
:= All_Overloadable
and Is_Overloadable
(E2
);
6238 -- Ada 2005 (AI-262): Protect against a form of Beaujolais effect
6239 -- that can occur in private_with clauses. Example:
6242 -- private with B; package A is
6243 -- package C is function B return Integer;
6245 -- V1 : Integer := B;
6246 -- private function B return Integer;
6247 -- V2 : Integer := B;
6250 -- V1 resolves to A.B, but V2 resolves to library unit B
6252 elsif Ekind
(E2
) = E_Function
6253 and then Scope
(E2
) = Standard_Standard
6254 and then Has_Private_With
(E2
)
6256 Only_One_Visible
:= False;
6257 All_Overloadable
:= False;
6258 Nvis_Is_Private_Subprg
:= True;
6265 -- On falling through this loop, we have checked that there are no
6266 -- immediately visible entities. Only_One_Visible is set if exactly
6267 -- one potentially use visible entity exists. All_Overloadable is
6268 -- set if all the potentially use visible entities are overloadable.
6269 -- The condition for legality is that either there is one potentially
6270 -- use visible entity, or if there is more than one, then all of them
6271 -- are overloadable.
6273 if Only_One_Visible
or All_Overloadable
then
6276 -- If there is more than one potentially use-visible entity and at
6277 -- least one of them non-overloadable, we have an error (RM 8.4(11)).
6278 -- Note that E points to the first such entity on the homonym list.
6281 -- If one of the entities is declared in an actual package, it
6282 -- was visible in the generic, and takes precedence over other
6283 -- entities that are potentially use-visible. The same applies
6284 -- if the entity is declared in a local instantiation of the
6285 -- current instance.
6289 -- Find the current instance
6291 Inst
:= Current_Scope
;
6292 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
6293 if Is_Generic_Instance
(Inst
) then
6297 Inst
:= Scope
(Inst
);
6300 -- Reexamine the candidate entities, giving priority to those
6301 -- that were visible within the generic.
6304 while Present
(E2
) loop
6305 Nested_Inst
:= Nearest_Enclosing_Instance
(E2
);
6307 -- The entity is declared within an actual package, or in a
6308 -- nested instance. The ">=" accounts for the case where the
6309 -- current instance and the nested instance are the same.
6311 if From_Actual_Package
(E2
)
6312 or else (Present
(Nested_Inst
)
6313 and then Scope_Depth
(Nested_Inst
) >=
6326 elsif Is_Predefined_Unit
(Current_Sem_Unit
) then
6327 -- A use clause in the body of a system file creates conflict
6328 -- with some entity in a user scope, while rtsfind is active.
6329 -- Keep only the entity coming from another predefined unit.
6332 while Present
(E2
) loop
6333 if In_Predefined_Unit
(E2
) then
6341 -- Entity must exist because predefined unit is correct
6343 raise Program_Error
;
6352 -- Come here with E set to the first immediately visible entity on
6353 -- the homonym chain. This is the one we want unless there is another
6354 -- immediately visible entity further on in the chain for an inner
6355 -- scope (RM 8.3(8)).
6357 <<Immediately_Visible_Entity
>> declare
6362 -- Find scope level of initial entity. When compiling through
6363 -- Rtsfind, the previous context is not completely invisible, and
6364 -- an outer entity may appear on the chain, whose scope is below
6365 -- the entry for Standard that delimits the current scope stack.
6366 -- Indicate that the level for this spurious entry is outside of
6367 -- the current scope stack.
6369 Level
:= Scope_Stack
.Last
;
6371 Scop
:= Scope_Stack
.Table
(Level
).Entity
;
6372 exit when Scop
= Scope
(E
);
6374 exit when Scop
= Standard_Standard
;
6377 -- Now search remainder of homonym chain for more inner entry
6378 -- If the entity is Standard itself, it has no scope, and we
6379 -- compare it with the stack entry directly.
6382 while Present
(E2
) loop
6383 if Is_Immediately_Visible
(E2
) then
6385 -- If a generic package contains a local declaration that
6386 -- has the same name as the generic, there may be a visibility
6387 -- conflict in an instance, where the local declaration must
6388 -- also hide the name of the corresponding package renaming.
6389 -- We check explicitly for a package declared by a renaming,
6390 -- whose renamed entity is an instance that is on the scope
6391 -- stack, and that contains a homonym in the same scope. Once
6392 -- we have found it, we know that the package renaming is not
6393 -- immediately visible, and that the identifier denotes the
6394 -- other entity (and its homonyms if overloaded).
6396 if Scope
(E
) = Scope
(E2
)
6397 and then Ekind
(E
) = E_Package
6398 and then Present
(Renamed_Entity
(E
))
6399 and then Is_Generic_Instance
(Renamed_Entity
(E
))
6400 and then In_Open_Scopes
(Renamed_Entity
(E
))
6401 and then Comes_From_Source
(N
)
6403 Set_Is_Immediately_Visible
(E
, False);
6407 for J
in Level
+ 1 .. Scope_Stack
.Last
loop
6408 if Scope_Stack
.Table
(J
).Entity
= Scope
(E2
)
6409 or else Scope_Stack
.Table
(J
).Entity
= E2
6422 -- At the end of that loop, E is the innermost immediately
6423 -- visible entity, so we are all set.
6426 -- Come here with entity found, and stored in E
6430 -- Check violation of No_Wide_Characters restriction
6432 Check_Wide_Character_Restriction
(E
, N
);
6434 -- When distribution features are available (Get_PCS_Name /=
6435 -- Name_No_DSA), a remote access-to-subprogram type is converted
6436 -- into a record type holding whatever information is needed to
6437 -- perform a remote call on an RCI subprogram. In that case we
6438 -- rewrite any occurrence of the RAS type into the equivalent record
6439 -- type here. 'Access attribute references and RAS dereferences are
6440 -- then implemented using specific TSSs. However when distribution is
6441 -- not available (case of Get_PCS_Name = Name_No_DSA), we bypass the
6442 -- generation of these TSSs, and we must keep the RAS type in its
6443 -- original access-to-subprogram form (since all calls through a
6444 -- value of such type will be local anyway in the absence of a PCS).
6446 if Comes_From_Source
(N
)
6447 and then Is_Remote_Access_To_Subprogram_Type
(E
)
6448 and then Ekind
(E
) = E_Access_Subprogram_Type
6449 and then Expander_Active
6450 and then Get_PCS_Name
/= Name_No_DSA
6452 Rewrite
(N
, New_Occurrence_Of
(Equivalent_Type
(E
), Sloc
(N
)));
6456 -- Set the entity. Note that the reason we call Set_Entity for the
6457 -- overloadable case, as opposed to Set_Entity_With_Checks is
6458 -- that in the overloaded case, the initial call can set the wrong
6459 -- homonym. The call that sets the right homonym is in Sem_Res and
6460 -- that call does use Set_Entity_With_Checks, so we don't miss
6463 if Is_Overloadable
(E
) then
6466 Set_Entity_With_Checks
(N
, E
);
6472 Set_Etype
(N
, Get_Full_View
(Etype
(E
)));
6475 if Debug_Flag_E
then
6476 Write_Str
(" found ");
6477 Write_Entity_Info
(E
, " ");
6480 if Is_Self_Hidden
(E
)
6482 (not Is_Record_Type
(Current_Scope
)
6483 or else Nkind
(Parent
(N
)) /= N_Pragma_Argument_Association
)
6485 Premature_Usage
(N
);
6487 -- If the entity is overloadable, collect all interpretations of the
6488 -- name for subsequent overload resolution. We optimize a bit here to
6489 -- do this only if we have an overloadable entity that is not on its
6490 -- own on the homonym chain.
6492 elsif Is_Overloadable
(E
)
6493 and then (Present
(Homonym
(E
)) or else Current_Entity
(N
) /= E
)
6495 Collect_Interps
(N
);
6497 -- Background: for an instance of a generic, expansion sets
6498 -- entity fields on names that refer to things declared
6499 -- outside of the instance, but leaves the entity field
6500 -- unset on names that should end up referring to things
6501 -- declared within the instance. These will instead be set by
6502 -- analysis - the idea is that if a name resolves a certain
6503 -- way in the generic, then we should get corresponding results
6504 -- if we resolve the corresponding name in an instance. For this
6505 -- to work, we have to prevent unrelated declarations that
6506 -- happen to be visible at the point of the instantiation from
6507 -- participating in resolution and causing problems (typically
6508 -- ambiguities, but incorrect resolutions are also probably
6509 -- possible). So here we filter out such unwanted interpretations.
6511 -- Note that there are other problems with this approach to
6512 -- implementing generic instances that are not addressed here.
6513 -- Inside a generic, we might have no trouble resolving a call
6514 -- where the two candidates are a function that returns a
6515 -- formal type and a function that returns Standard.Integer.
6516 -- If we instantiate that generic and the corresponding actual
6517 -- type is Standard.Integer, then we may incorrectly reject the
6518 -- corresponding call in the instance as ambiguous (or worse,
6519 -- we may quietly choose the wrong resolution).
6521 -- Another such problem can occur with a type derived from a
6522 -- formal derived type. In an instance, such a type may have
6523 -- inherited subprograms that are not present in the generic.
6524 -- These can then interfere with name resolution (e.g., if
6525 -- some declaration is visible via a use-clause in the generic
6526 -- and some name in the generic refers to it, then the
6527 -- corresponding declaration in an instance may be hidden by
6528 -- a directly visible inherited subprogram and the corresponding
6529 -- name in the instance may then incorrectly refer to the
6530 -- inherited subprogram).
6534 function Is_Actual_Subp_Of_Inst
6535 (E
: Entity_Id
; Inst
: Entity_Id
) return Boolean;
6536 -- Return True if E is an actual parameter
6537 -- corresponding to a formal subprogram of the
6538 -- instantiation Inst.
6540 function Is_Extraneously_Visible
6541 (E
: Entity_Id
; Inst
: Entity_Id
) return Boolean;
6542 -- Return True if E is an interpretation that should
6543 -- be filtered out. That is, if E is an "unwanted"
6544 -- resolution candidate as described in the
6545 -- preceding "Background:" commment.
6547 function Is_Generic_Actual_Subp_Name
6548 (N
: Node_Id
) return Boolean;
6549 -- Return True if N is the name of a subprogram
6550 -- renaming generated for a generic actual.
6552 ----------------------------
6553 -- Is_Actual_Subp_Of_Inst --
6554 ----------------------------
6556 function Is_Actual_Subp_Of_Inst
6557 (E
: Entity_Id
; Inst
: Entity_Id
) return Boolean
6560 Generic_From_E
, Generic_From_Inst
: Entity_Id
;
6563 -- Why is Is_Generic_Actual_Subprogram undefined
6564 -- in the E_Operator case?
6566 if Ekind
(E
) not in E_Function | E_Procedure
6567 or else not Is_Generic_Actual_Subprogram
(E
)
6572 Decl
:= Enclosing_Declaration
(E
);
6574 -- Look for the suprogram renaming declaration built
6575 -- for a generic actual subprogram. Unclear why
6576 -- Original_Node call is needed, but sometimes it is.
6578 if Decl
not in N_Subprogram_Renaming_Declaration_Id
then
6579 Decl
:= Original_Node
(Decl
);
6582 if Decl
in N_Subprogram_Renaming_Declaration_Id
then
6584 Scope
(Corresponding_Formal_Spec
(Decl
));
6586 -- ??? In the case of a generic formal subprogram
6587 -- which has a pre/post condition, it is unclear how
6588 -- to find the Corresponding_Formal_Spec-bearing node.
6590 Generic_From_E
:= Empty
;
6594 Inst_Parent
: Node_Id
:= Parent
(Inst
);
6596 if Nkind
(Inst_Parent
) = N_Defining_Program_Unit_Name
6598 Inst_Parent
:= Parent
(Inst_Parent
);
6601 Generic_From_Inst
:= Generic_Parent
(Inst_Parent
);
6604 return Generic_From_E
= Generic_From_Inst
6605 and then Present
(Generic_From_E
);
6606 end Is_Actual_Subp_Of_Inst
;
6608 -----------------------------
6609 -- Is_Extraneously_Visible --
6610 -----------------------------
6612 function Is_Extraneously_Visible
6613 (E
: Entity_Id
; Inst
: Entity_Id
) return Boolean is
6615 -- Return False in various non-extraneous cases.
6616 -- If none of those apply, then return True.
6618 if Within_Scope
(E
, Inst
) then
6619 -- return False if E declared within Inst
6622 elsif Is_Actual_Subp_Of_Inst
(E
, Inst
) then
6623 -- Return False if E is an actual subprogram,
6624 -- and therefore may be referenced within Inst.
6627 elsif Nkind
(Parent
(E
)) = N_Subtype_Declaration
6628 and then Defining_Identifier
(Parent
(E
)) /= E
6630 -- Return False for a primitive subp of an
6631 -- actual corresponding to a formal type.
6635 elsif not In_Open_Scopes
(Scope
(E
)) then
6636 -- Return False if this candidate is not
6637 -- declared in a currently open scope.
6643 -- We want to know whether the declaration of
6644 -- E comes textually after the declaration of
6645 -- the generic that Inst is an instance of
6646 -- (and after the generic body if there is one).
6647 -- To compare, we climb up the deeper of the two
6648 -- scope chains until we the levels match.
6649 -- There is a separate loop for each starting
6650 -- point, but we will execute zero iterations
6651 -- for at least one of the two loops.
6652 -- For each Xxx_Scope, we have a corresponding
6653 -- Xxx_Trailer; the latter is the predecessor of
6654 -- the former in the scope traversal.
6656 E_Trailer
: Entity_Id
:= E
;
6657 E_Scope
: Entity_Id
:= Scope
(E
);
6658 pragma Assert
(Present
(E_Scope
));
6660 -- the generic that Inst is an instance of
6661 Gen_Trailer
: Entity_Id
:=
6662 Generic_Parent
(Specification
6663 (Unit_Declaration_Node
(Inst
)));
6664 Gen_Scope
: Entity_Id
;
6666 function Has_Formal_Package_Parameter
6667 (Generic_Id
: Entity_Id
) return Boolean;
6668 -- Return True iff given generic has at least one
6669 -- formal package parameter.
6671 ----------------------------------
6672 -- Has_Formal_Package_Parameter --
6673 ----------------------------------
6675 function Has_Formal_Package_Parameter
6676 (Generic_Id
: Entity_Id
) return Boolean is
6677 Formal_Decl
: Node_Id
:=
6678 First
(Generic_Formal_Declarations
6679 (Enclosing_Generic_Unit
(Generic_Id
)));
6681 while Present
(Formal_Decl
) loop
6682 if Nkind
(Original_Node
(Formal_Decl
)) =
6683 N_Formal_Package_Declaration
6691 end Has_Formal_Package_Parameter
;
6694 if No
(Gen_Trailer
) then
6695 -- Dunno how this can happen, but it can.
6698 if Has_Formal_Package_Parameter
(Gen_Trailer
)
6700 -- Punt on sorting out what is visible via a
6706 if Is_Child_Unit
(Gen_Trailer
)
6707 and then Is_Generic_Unit
6709 (Parent
(Gen_Trailer
))))
6711 -- Punt on dealing with how the FE fails
6712 -- to build a tree for a "sprouted" generic
6713 -- so that what should be a reference to
6714 -- I1.G2 instead points into G1.G2 .
6719 Gen_Scope
:= Scope
(Gen_Trailer
);
6721 while Scope_Depth
(E_Scope
)
6722 > Scope_Depth
(Gen_Scope
)
6724 E_Trailer
:= E_Scope
;
6725 E_Scope
:= Scope
(E_Scope
);
6727 while Scope_Depth
(E_Scope
)
6728 < Scope_Depth
(Gen_Scope
)
6730 Gen_Trailer
:= Gen_Scope
;
6731 Gen_Scope
:= Scope
(Gen_Scope
);
6735 if Gen_Scope
= E_Scope
then
6736 -- if Gen_Trailer and E_Trailer are declared
6737 -- in the same declarative part and E_Trailer
6738 -- occurs after the declaration (and body, if
6739 -- there is one) of Gen_Trailer, then
6740 -- return True because E was declared after
6741 -- the generic that Inst is an instance of
6742 -- (and also after that generic's body, if it
6745 if Is_Package_Or_Generic_Package
(Gen_Trailer
)
6746 and then Present
(Package_Body
(Gen_Trailer
))
6750 (Package_Spec
(Gen_Trailer
));
6754 Id
: Entity_Id
:= Gen_Trailer
;
6758 -- E_Trailer presumably occurred
6759 -- earlier on the entity list than
6760 -- Gen_Trailer. So E preceded the
6761 -- generic that Inst is an instance
6762 -- of (or the body of that generic if
6763 -- it has one) and so could have
6764 -- been referenced within the generic.
6767 exit when Id
= E_Trailer
;
6775 if Present
(Nearest_Enclosing_Instance
(Inst
)) then
6776 return Is_Extraneously_Visible
6777 (E
=> E
, Inst
=> Nearest_Enclosing_Instance
(Inst
));
6779 -- The preceding Nearest_Enclosing_Instance test
6780 -- doesn't handle the case of an instance of a
6781 -- "sprouted" generic. For example, if Inst=I2 in
6782 -- generic package G1
6783 -- generic package G1.G2;
6784 -- package I1 is new G1;
6785 -- package I2 is new I1.G2;
6786 -- then N_E_I (Inst) = Empty. So deal with that case.
6788 elsif Present
(Nearest_Enclosing_Instance
(E
)) then
6789 return Is_Extraneously_Visible
6790 (E
=> Nearest_Enclosing_Instance
(E
),
6795 end Is_Extraneously_Visible
;
6797 ---------------------------------
6798 -- Is_Generic_Actual_Subp_Name --
6799 ---------------------------------
6801 function Is_Generic_Actual_Subp_Name
6802 (N
: Node_Id
) return Boolean
6804 Decl
: constant Node_Id
:= Enclosing_Declaration
(N
);
6806 return Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
6807 and then Present
(Corresponding_Formal_Spec
(Decl
));
6808 end Is_Generic_Actual_Subp_Name
;
6812 Inst
: Entity_Id
:= Current_Scope
;
6815 while Present
(Inst
)
6816 and then not Is_Generic_Instance
(Inst
)
6818 Inst
:= Scope
(Inst
);
6821 if Present
(Inst
) then
6822 Get_First_Interp
(N
, I
, It
);
6823 while Present
(It
.Nam
) loop
6824 if Is_Extraneously_Visible
(E
=> It
.Nam
, Inst
=> Inst
)
6825 and then not Is_Generic_Actual_Subp_Name
(N
)
6829 Get_Next_Interp
(I
, It
);
6835 -- If no homonyms were visible, the entity is unambiguous
6837 if not Is_Overloaded
(N
) then
6838 if not Is_Actual_Parameter
then
6839 Generate_Reference
(E
, N
);
6843 -- Case of non-overloadable entity, set the entity providing that
6844 -- we do not have the case of a discriminant reference within a
6845 -- default expression. Such references are replaced with the
6846 -- corresponding discriminal, which is the formal corresponding to
6847 -- to the discriminant in the initialization procedure.
6850 -- Entity is unambiguous, indicate that it is referenced here
6852 -- For a renaming of an object, always generate simple reference,
6853 -- we don't try to keep track of assignments in this case, except
6854 -- in SPARK mode where renamings are traversed for generating
6855 -- local effects of subprograms.
6858 and then Present
(Renamed_Object
(E
))
6859 and then not GNATprove_Mode
6861 Generate_Reference
(E
, N
);
6863 -- If the renamed entity is a private protected component,
6864 -- reference the original component as well. This needs to be
6865 -- done because the private renamings are installed before any
6866 -- analysis has occurred. Reference to a private component will
6867 -- resolve to the renaming and the original component will be
6868 -- left unreferenced, hence the following.
6870 if Is_Prival
(E
) then
6871 Generate_Reference
(Prival_Link
(E
), N
);
6874 -- One odd case is that we do not want to set the Referenced flag
6875 -- if the entity is a label, and the identifier is the label in
6876 -- the source, since this is not a reference from the point of
6877 -- view of the user.
6879 elsif Nkind
(Parent
(N
)) = N_Label
then
6881 R
: constant Boolean := Referenced
(E
);
6884 -- Generate reference unless this is an actual parameter
6885 -- (see comment below).
6887 if not Is_Actual_Parameter
then
6888 Generate_Reference
(E
, N
);
6889 Set_Referenced
(E
, R
);
6893 -- Normal case, not a label: generate reference
6896 if not Is_Actual_Parameter
then
6898 -- Package or generic package is always a simple reference
6900 if Is_Package_Or_Generic_Package
(E
) then
6901 Generate_Reference
(E
, N
, 'r');
6903 -- Else see if we have a left hand side
6906 case Known_To_Be_Assigned
(N
, Only_LHS
=> True) is
6908 Generate_Reference
(E
, N
, 'm');
6911 Generate_Reference
(E
, N
, 'r');
6918 Set_Entity_Or_Discriminal
(N
, E
);
6920 -- The name may designate a generalized reference, in which case
6921 -- the dereference interpretation will be included. Context is
6922 -- one in which a name is legal.
6924 if Ada_Version
>= Ada_2012
6926 (Nkind
(Parent
(N
)) in N_Subexpr
6927 or else Nkind
(Parent
(N
)) in N_Assignment_Statement
6928 | N_Object_Declaration
6929 | N_Parameter_Association
)
6931 Check_Implicit_Dereference
(N
, Etype
(E
));
6936 -- Mark relevant use-type and use-package clauses as effective if the
6937 -- node in question is not overloaded and therefore does not require
6940 -- Note: Generic actual subprograms do not follow the normal resolution
6941 -- path, so ignore the fact that they are overloaded and mark them
6944 if Nkind
(N
) not in N_Subexpr
or else not Is_Overloaded
(N
) then
6945 Mark_Use_Clauses
(N
);
6948 -- Come here with entity set
6951 Check_Restriction_No_Use_Of_Entity
(N
);
6953 -- Annotate the tree by creating a variable reference marker in case the
6954 -- original variable reference is folded or optimized away. The variable
6955 -- reference marker is automatically saved for later examination by the
6956 -- ABE Processing phase. Variable references which act as actuals in a
6957 -- call require special processing and are left to Resolve_Actuals. The
6958 -- reference is a write when it appears on the left hand side of an
6961 if Needs_Variable_Reference_Marker
(N
=> N
, Calls_OK
=> False) then
6963 Is_Assignment_LHS
: constant Boolean := Known_To_Be_Assigned
(N
);
6966 Build_Variable_Reference_Marker
6968 Read
=> not Is_Assignment_LHS
,
6969 Write
=> Is_Assignment_LHS
);
6972 end Find_Direct_Name
;
6974 ------------------------
6975 -- Find_Expanded_Name --
6976 ------------------------
6978 -- This routine searches the homonym chain of the entity until it finds
6979 -- an entity declared in the scope denoted by the prefix. If the entity
6980 -- is private, it may nevertheless be immediately visible, if we are in
6981 -- the scope of its declaration.
6983 procedure Find_Expanded_Name
(N
: Node_Id
) is
6984 function In_Abstract_View_Pragma
(Nod
: Node_Id
) return Boolean;
6985 -- Determine whether expanded name Nod appears within a pragma which is
6986 -- a suitable context for an abstract view of a state or variable. The
6987 -- following pragmas fall in this category:
6994 -- In addition, pragma Abstract_State is also considered suitable even
6995 -- though it is an illegal context for an abstract view as this allows
6996 -- for proper resolution of abstract views of variables. This illegal
6997 -- context is later flagged in the analysis of indicator Part_Of.
6999 -----------------------------
7000 -- In_Abstract_View_Pragma --
7001 -----------------------------
7003 function In_Abstract_View_Pragma
(Nod
: Node_Id
) return Boolean is
7007 -- Climb the parent chain looking for a pragma
7010 while Present
(Par
) loop
7011 if Nkind
(Par
) = N_Pragma
then
7012 if Pragma_Name_Unmapped
(Par
)
7013 in Name_Abstract_State
7017 | Name_Refined_Depends
7018 | Name_Refined_Global
7022 -- Otherwise the pragma is not a legal context for an abstract
7029 -- Prevent the search from going too far
7031 elsif Is_Body_Or_Package_Declaration
(Par
) then
7035 Par
:= Parent
(Par
);
7039 end In_Abstract_View_Pragma
;
7043 Selector
: constant Node_Id
:= Selector_Name
(N
);
7045 Candidate
: Entity_Id
:= Empty
;
7049 -- Start of processing for Find_Expanded_Name
7052 P_Name
:= Entity
(Prefix
(N
));
7054 -- If the prefix is a renamed package, look for the entity in the
7055 -- original package.
7057 if Ekind
(P_Name
) = E_Package
7058 and then Present
(Renamed_Entity
(P_Name
))
7060 P_Name
:= Renamed_Entity
(P_Name
);
7062 if From_Limited_With
(P_Name
)
7063 and then not Unit_Is_Visible
(Cunit
(Get_Source_Unit
(P_Name
)))
7066 ("renaming of limited view of package & not usable in this"
7067 & " context (RM 8.5.3(3.1/2))", Prefix
(N
), P_Name
);
7069 elsif Has_Limited_View
(P_Name
)
7070 and then not Unit_Is_Visible
(Cunit
(Get_Source_Unit
(P_Name
)))
7071 and then not Is_Visible_Through_Renamings
(P_Name
)
7074 ("renaming of limited view of package & not usable in this"
7075 & " context (RM 8.5.3(3.1/2))", Prefix
(N
), P_Name
);
7078 -- Rewrite node with entity field pointing to renamed object
7080 Rewrite
(Prefix
(N
), New_Copy
(Prefix
(N
)));
7081 Set_Entity
(Prefix
(N
), P_Name
);
7083 -- If the prefix is an object of a concurrent type, look for
7084 -- the entity in the associated task or protected type.
7086 elsif Is_Concurrent_Type
(Etype
(P_Name
)) then
7087 P_Name
:= Etype
(P_Name
);
7090 Id
:= Current_Entity
(Selector
);
7093 Is_New_Candidate
: Boolean;
7096 while Present
(Id
) loop
7097 if Scope
(Id
) = P_Name
then
7099 Is_New_Candidate
:= True;
7101 -- Handle abstract views of states and variables. These are
7102 -- acceptable candidates only when the reference to the view
7103 -- appears in certain pragmas.
7105 if Ekind
(Id
) = E_Abstract_State
7106 and then From_Limited_With
(Id
)
7107 and then Present
(Non_Limited_View
(Id
))
7109 if In_Abstract_View_Pragma
(N
) then
7110 Candidate
:= Non_Limited_View
(Id
);
7111 Is_New_Candidate
:= True;
7113 -- Hide the candidate because it is not used in a proper
7118 Is_New_Candidate
:= False;
7122 -- Ada 2005 (AI-217): Handle shadow entities associated with
7123 -- types declared in limited-withed nested packages. We don't need
7124 -- to handle E_Incomplete_Subtype entities because the entities
7125 -- in the limited view are always E_Incomplete_Type and
7126 -- E_Class_Wide_Type entities (see Build_Limited_Views).
7128 -- Regarding the expression used to evaluate the scope, it
7129 -- is important to note that the limited view also has shadow
7130 -- entities associated nested packages. For this reason the
7131 -- correct scope of the entity is the scope of the real entity.
7132 -- The non-limited view may itself be incomplete, in which case
7133 -- get the full view if available.
7135 elsif Ekind
(Id
) in E_Incomplete_Type | E_Class_Wide_Type
7136 and then From_Limited_With
(Id
)
7137 and then Present
(Non_Limited_View
(Id
))
7138 and then Scope
(Non_Limited_View
(Id
)) = P_Name
7140 Candidate
:= Get_Full_View
(Non_Limited_View
(Id
));
7141 Is_New_Candidate
:= True;
7143 -- Handle special case where the prefix is a renaming of a shadow
7144 -- package which is visible. Required to avoid reporting spurious
7147 elsif Ekind
(P_Name
) = E_Package
7148 and then From_Limited_With
(P_Name
)
7149 and then not From_Limited_With
(Id
)
7150 and then Sloc
(Scope
(Id
)) = Sloc
(P_Name
)
7151 and then Unit_Is_Visible
(Cunit
(Get_Source_Unit
(P_Name
)))
7153 Candidate
:= Get_Full_View
(Id
);
7154 Is_New_Candidate
:= True;
7156 -- An unusual case arises with a fully qualified name for an
7157 -- entity local to a generic child unit package, within an
7158 -- instantiation of that package. The name of the unit now
7159 -- denotes the renaming created within the instance. This is
7160 -- only relevant in an instance body, see below.
7162 elsif Is_Generic_Instance
(Scope
(Id
))
7163 and then In_Open_Scopes
(Scope
(Id
))
7164 and then In_Instance_Body
7165 and then Ekind
(Scope
(Id
)) = E_Package
7166 and then Ekind
(Id
) = E_Package
7167 and then Renamed_Entity
(Id
) = Scope
(Id
)
7168 and then Is_Immediately_Visible
(P_Name
)
7170 Is_New_Candidate
:= True;
7173 Is_New_Candidate
:= False;
7176 if Is_New_Candidate
then
7178 -- If entity is a child unit, either it is a visible child of
7179 -- the prefix, or we are in the body of a generic prefix, as
7180 -- will happen when a child unit is instantiated in the body
7181 -- of a generic parent. This is because the instance body does
7182 -- not restore the full compilation context, given that all
7183 -- non-local references have been captured.
7185 if Is_Child_Unit
(Id
) or else P_Name
= Standard_Standard
then
7186 exit when Is_Visible_Lib_Unit
(Id
)
7187 or else (Is_Child_Unit
(Id
)
7188 and then In_Open_Scopes
(Scope
(Id
))
7189 and then In_Instance_Body
);
7191 exit when not Is_Hidden
(Id
);
7194 exit when Is_Immediately_Visible
(Id
);
7202 and then Ekind
(P_Name
) in E_Procedure | E_Function
7203 and then Is_Generic_Instance
(P_Name
)
7205 -- Expanded name denotes entity in (instance of) generic subprogram.
7206 -- The entity may be in the subprogram instance, or may denote one of
7207 -- the formals, which is declared in the enclosing wrapper package.
7209 P_Name
:= Scope
(P_Name
);
7211 Id
:= Current_Entity
(Selector
);
7212 while Present
(Id
) loop
7213 exit when Scope
(Id
) = P_Name
;
7218 if No
(Id
) or else Chars
(Id
) /= Chars
(Selector
) then
7219 Set_Etype
(N
, Any_Type
);
7221 -- If we are looking for an entity defined in System, try to find it
7222 -- in the child package that may have been provided as an extension
7223 -- to System. The Extend_System pragma will have supplied the name of
7224 -- the extension, which may have to be loaded.
7226 if Chars
(P_Name
) = Name_System
7227 and then Scope
(P_Name
) = Standard_Standard
7228 and then Present
(System_Extend_Unit
)
7229 and then Present_System_Aux
(N
)
7231 Set_Entity
(Prefix
(N
), System_Aux_Id
);
7232 Find_Expanded_Name
(N
);
7235 -- There is an implicit instance of the predefined operator in
7236 -- the given scope. The operator entity is defined in Standard.
7237 -- Has_Implicit_Operator makes the node into an Expanded_Name.
7239 elsif Nkind
(Selector
) = N_Operator_Symbol
7240 and then Has_Implicit_Operator
(N
)
7244 -- If there is no literal defined in the scope denoted by the
7245 -- prefix, the literal may belong to (a type derived from)
7246 -- Standard_Character, for which we have no explicit literals.
7248 elsif Nkind
(Selector
) = N_Character_Literal
7249 and then Has_Implicit_Character_Literal
(N
)
7254 -- If the prefix is a single concurrent object, use its name in
7255 -- the error message, rather than that of the anonymous type.
7257 if Is_Concurrent_Type
(P_Name
)
7258 and then Is_Internal_Name
(Chars
(P_Name
))
7260 Error_Msg_Node_2
:= Entity
(Prefix
(N
));
7262 Error_Msg_Node_2
:= P_Name
;
7265 if P_Name
= System_Aux_Id
then
7266 P_Name
:= Scope
(P_Name
);
7267 Set_Entity
(Prefix
(N
), P_Name
);
7270 if Present
(Candidate
) then
7272 -- If we know that the unit is a child unit we can give a more
7273 -- accurate error message.
7275 if Is_Child_Unit
(Candidate
) then
7277 -- If the candidate is a private child unit and we are in
7278 -- the visible part of a public unit, specialize the error
7279 -- message. There might be a private with_clause for it,
7280 -- but it is not currently active.
7282 if Is_Private_Descendant
(Candidate
)
7283 and then Ekind
(Current_Scope
) = E_Package
7284 and then not In_Private_Part
(Current_Scope
)
7285 and then not Is_Private_Descendant
(Current_Scope
)
7288 ("private child unit& is not visible here", Selector
);
7290 -- Normal case where we have a missing with for a child unit
7293 Error_Msg_Qual_Level
:= 99;
7294 Error_Msg_NE
-- CODEFIX
7295 ("missing `WITH &;`", Selector
, Candidate
);
7296 Error_Msg_Qual_Level
:= 0;
7299 -- Here we don't know that this is a child unit
7302 Error_Msg_NE
("& is not a visible entity of&", N
, Selector
);
7306 -- Within the instantiation of a child unit, the prefix may
7307 -- denote the parent instance, but the selector has the name
7308 -- of the original child. That is to say, when A.B appears
7309 -- within an instantiation of generic child unit B, the scope
7310 -- stack includes an instance of A (P_Name) and an instance
7311 -- of B under some other name. We scan the scope to find this
7312 -- child instance, which is the desired entity.
7313 -- Note that the parent may itself be a child instance, if
7314 -- the reference is of the form A.B.C, in which case A.B has
7315 -- already been rewritten with the proper entity.
7317 if In_Open_Scopes
(P_Name
)
7318 and then Is_Generic_Instance
(P_Name
)
7321 Gen_Par
: constant Entity_Id
:=
7322 Generic_Parent
(Specification
7323 (Unit_Declaration_Node
(P_Name
)));
7324 S
: Entity_Id
:= Current_Scope
;
7328 for J
in reverse 0 .. Scope_Stack
.Last
loop
7329 S
:= Scope_Stack
.Table
(J
).Entity
;
7331 exit when S
= Standard_Standard
;
7333 if Ekind
(S
) in E_Function | E_Package | E_Procedure
7336 Generic_Parent
(Specification
7337 (Unit_Declaration_Node
(S
)));
7339 -- Check that P is a generic child of the generic
7340 -- parent of the prefix.
7343 and then Chars
(P
) = Chars
(Selector
)
7344 and then Scope
(P
) = Gen_Par
7355 -- If this is a selection from Ada, System or Interfaces, then
7356 -- we assume a missing with for the corresponding package.
7358 if Is_Known_Unit
(N
)
7359 and then not (Present
(Entity
(Prefix
(N
)))
7360 and then Scope
(Entity
(Prefix
(N
))) /=
7363 if not Error_Posted
(N
) then
7365 ("& is not a visible entity of&", Prefix
(N
), Selector
);
7366 Error_Missing_With_Of_Known_Unit
(Prefix
(N
));
7369 -- If this is a selection from a dummy package, then suppress
7370 -- the error message, of course the entity is missing if the
7371 -- package is missing.
7373 elsif Sloc
(Error_Msg_Node_2
) = No_Location
then
7376 -- Here we have the case of an undefined component
7379 -- The prefix may hide a homonym in the context that
7380 -- declares the desired entity. This error can use a
7381 -- specialized message.
7383 if In_Open_Scopes
(P_Name
) then
7385 H
: constant Entity_Id
:= Homonym
(P_Name
);
7389 and then Is_Compilation_Unit
(H
)
7391 (Is_Immediately_Visible
(H
)
7392 or else Is_Visible_Lib_Unit
(H
))
7394 Id
:= First_Entity
(H
);
7395 while Present
(Id
) loop
7396 if Chars
(Id
) = Chars
(Selector
) then
7397 Error_Msg_Qual_Level
:= 99;
7398 Error_Msg_Name_1
:= Chars
(Selector
);
7400 ("% not declared in&", N
, P_Name
);
7402 ("\use fully qualified name starting with "
7403 & "Standard to make& visible", N
, H
);
7404 Error_Msg_Qual_Level
:= 0;
7412 -- If not found, standard error message
7414 Error_Msg_NE
("& not declared in&", N
, Selector
);
7420 -- Might be worth specializing the case when the prefix
7421 -- is a limited view.
7422 -- ... not declared in limited view of...
7424 Error_Msg_NE
("& not declared in&", N
, Selector
);
7427 -- Check for misspelling of some entity in prefix
7429 Id
:= First_Entity
(P_Name
);
7430 while Present
(Id
) loop
7431 if Is_Bad_Spelling_Of
(Chars
(Id
), Chars
(Selector
))
7432 and then not Is_Internal_Name
(Chars
(Id
))
7434 Error_Msg_NE
-- CODEFIX
7435 ("possible misspelling of&", Selector
, Id
);
7442 -- Specialize the message if this may be an instantiation
7443 -- of a child unit that was not mentioned in the context.
7445 if Nkind
(Parent
(N
)) = N_Package_Instantiation
7446 and then Is_Generic_Instance
(Entity
(Prefix
(N
)))
7447 and then Is_Compilation_Unit
7448 (Generic_Parent
(Parent
(Entity
(Prefix
(N
)))))
7450 Error_Msg_Node_2
:= Selector
;
7451 Error_Msg_N
-- CODEFIX
7452 ("\missing `WITH &.&;`", Prefix
(N
));
7462 if Comes_From_Source
(N
)
7463 and then Is_Remote_Access_To_Subprogram_Type
(Id
)
7464 and then Ekind
(Id
) = E_Access_Subprogram_Type
7465 and then Present
(Equivalent_Type
(Id
))
7467 -- If we are not actually generating distribution code (i.e. the
7468 -- current PCS is the dummy non-distributed version), then the
7469 -- Equivalent_Type will be missing, and Id should be treated as
7470 -- a regular access-to-subprogram type.
7472 Id
:= Equivalent_Type
(Id
);
7473 Set_Chars
(Selector
, Chars
(Id
));
7476 -- Ada 2005 (AI-50217): Check usage of entities in limited withed units
7478 if Ekind
(P_Name
) = E_Package
and then From_Limited_With
(P_Name
) then
7479 if From_Limited_With
(Id
)
7480 or else Is_Type
(Id
)
7481 or else Ekind
(Id
) = E_Package
7486 ("limited withed package can only be used to access incomplete "
7491 if Is_Task_Type
(P_Name
)
7492 and then ((Ekind
(Id
) = E_Entry
7493 and then Nkind
(Parent
(N
)) /= N_Attribute_Reference
)
7495 (Ekind
(Id
) = E_Entry_Family
7497 Nkind
(Parent
(Parent
(N
))) /= N_Attribute_Reference
))
7499 -- If both the task type and the entry are in scope, this may still
7500 -- be the expanded name of an entry formal.
7502 if In_Open_Scopes
(Id
)
7503 and then Nkind
(Parent
(N
)) = N_Selected_Component
7508 -- It is an entry call after all, either to the current task
7509 -- (which will deadlock) or to an enclosing task.
7511 Analyze_Selected_Component
(N
);
7517 when N_Selected_Component
=>
7518 Reinit_Field_To_Zero
(N
, F_Is_Prefixed_Call
);
7519 Change_Selected_Component_To_Expanded_Name
(N
);
7521 when N_Expanded_Name
=>
7525 pragma Assert
(False);
7528 -- Preserve relevant elaboration-related attributes of the context which
7529 -- are no longer available or very expensive to recompute once analysis,
7530 -- resolution, and expansion are over.
7532 Mark_Elaboration_Attributes
7538 -- Set appropriate type
7540 if Is_Type
(Id
) then
7543 Set_Etype
(N
, Get_Full_View
(Etype
(Id
)));
7546 -- Do style check and generate reference, but skip both steps if this
7547 -- entity has homonyms, since we may not have the right homonym set yet.
7548 -- The proper homonym will be set during the resolve phase.
7550 if Has_Homonym
(Id
) then
7554 Set_Entity_Or_Discriminal
(N
, Id
);
7556 case Known_To_Be_Assigned
(N
, Only_LHS
=> True) is
7558 Generate_Reference
(Id
, N
, 'm');
7561 Generate_Reference
(Id
, N
, 'r');
7566 -- Check for violation of No_Wide_Characters
7568 Check_Wide_Character_Restriction
(Id
, N
);
7570 if Is_Self_Hidden
(Id
) then
7571 Premature_Usage
(N
);
7573 elsif Is_Overloadable
(Id
) and then Present
(Homonym
(Id
)) then
7575 H
: Entity_Id
:= Homonym
(Id
);
7578 while Present
(H
) loop
7579 if Scope
(H
) = Scope
(Id
)
7580 and then (not Is_Hidden
(H
)
7581 or else Is_Immediately_Visible
(H
))
7583 Collect_Interps
(N
);
7590 -- If an extension of System is present, collect possible explicit
7591 -- overloadings declared in the extension.
7593 if Chars
(P_Name
) = Name_System
7594 and then Scope
(P_Name
) = Standard_Standard
7595 and then Present
(System_Extend_Unit
)
7596 and then Present_System_Aux
(N
)
7598 H
:= Current_Entity
(Id
);
7600 while Present
(H
) loop
7601 if Scope
(H
) = System_Aux_Id
then
7602 Add_One_Interp
(N
, H
, Etype
(H
));
7611 if Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
7612 and then Scope
(Id
) /= Standard_Standard
7614 -- In addition to user-defined operators in the given scope, there
7615 -- may be an implicit instance of the predefined operator. The
7616 -- operator (defined in Standard) is found in Has_Implicit_Operator,
7617 -- and added to the interpretations. Procedure Add_One_Interp will
7618 -- determine which hides which.
7620 if Has_Implicit_Operator
(N
) then
7625 -- If there is a single interpretation for N we can generate a
7626 -- reference to the unique entity found.
7628 if Is_Overloadable
(Id
) and then not Is_Overloaded
(N
) then
7629 Generate_Reference
(Id
, N
);
7632 -- Mark relevant use-type and use-package clauses as effective if the
7633 -- node in question is not overloaded and therefore does not require
7636 if Nkind
(N
) not in N_Subexpr
or else not Is_Overloaded
(N
) then
7637 Mark_Use_Clauses
(N
);
7640 Check_Restriction_No_Use_Of_Entity
(N
);
7642 -- Annotate the tree by creating a variable reference marker in case the
7643 -- original variable reference is folded or optimized away. The variable
7644 -- reference marker is automatically saved for later examination by the
7645 -- ABE Processing phase. Variable references which act as actuals in a
7646 -- call require special processing and are left to Resolve_Actuals. The
7647 -- reference is a write when it appears on the left hand side of an
7650 if Needs_Variable_Reference_Marker
7655 Is_Assignment_LHS
: constant Boolean := Known_To_Be_Assigned
(N
);
7658 Build_Variable_Reference_Marker
7660 Read
=> not Is_Assignment_LHS
,
7661 Write
=> Is_Assignment_LHS
);
7664 end Find_Expanded_Name
;
7666 --------------------
7667 -- Find_First_Use --
7668 --------------------
7670 function Find_First_Use
(Use_Clause
: Node_Id
) return Node_Id
is
7674 -- Loop through the Prev_Use_Clause chain
7677 while Present
(Prev_Use_Clause
(Curr
)) loop
7678 Curr
:= Prev_Use_Clause
(Curr
);
7684 -------------------------
7685 -- Find_Renamed_Entity --
7686 -------------------------
7688 function Find_Renamed_Entity
7692 Is_Actual
: Boolean := False) return Entity_Id
7695 I1
: Interp_Index
:= 0; -- Suppress junk warnings
7701 function Find_Nearer_Entity
7704 Old2_S
: Entity_Id
) return Entity_Id
;
7705 -- Determine whether one of Old_S1 and Old_S2 is nearer to New_S than
7706 -- the other, and return it if so. Return Empty otherwise. We use this
7707 -- in conjunction with Inherit_Renamed_Profile to simplify later type
7708 -- disambiguation for actual subprograms in instances.
7710 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean;
7711 -- If the renamed entity is an implicit operator, check whether it is
7712 -- visible because its operand type is properly visible. This check
7713 -- applies to explicit renamed entities that appear in the source in a
7714 -- renaming declaration or a formal subprogram instance, but not to
7715 -- default generic actuals with a name.
7717 function Report_Overload
return Entity_Id
;
7718 -- List possible interpretations, and specialize message in the
7719 -- case of a generic actual.
7721 function Within
(Inner
, Outer
: Entity_Id
) return Boolean;
7722 -- Determine whether a candidate subprogram is defined within the
7723 -- enclosing instance. If yes, it has precedence over outer candidates.
7725 --------------------------
7726 -- Find_Nearer_Entity --
7727 --------------------------
7729 function Find_Nearer_Entity
7732 Old2_S
: Entity_Id
) return Entity_Id
7740 New_F
:= First_Formal
(New_S
);
7741 Old1_F
:= First_Formal
(Old1_S
);
7742 Old2_F
:= First_Formal
(Old2_S
);
7744 -- The criterion is whether the type of the formals of one of Old1_S
7745 -- and Old2_S is an ancestor subtype of the type of the corresponding
7746 -- formals of New_S while the other is not (we already know that they
7747 -- are all subtypes of the same base type).
7749 -- This makes it possible to find the more correct renamed entity in
7750 -- the case of a generic instantiation nested in an enclosing one for
7751 -- which different formal types get the same actual type, which will
7752 -- in turn make it possible for Inherit_Renamed_Profile to preserve
7753 -- types on formal parameters and ultimately simplify disambiguation.
7755 -- Consider the follow package G:
7758 -- type Item_T is private;
7759 -- with function Compare (L, R: Item_T) return Boolean is <>;
7761 -- type Bound_T is private;
7762 -- with function Compare (L, R : Bound_T) return Boolean is <>;
7767 -- package body G is
7768 -- package My_Inner is Inner_G (Bound_T);
7772 -- with the following package Inner_G:
7775 -- type T is private;
7776 -- with function Compare (L, R: T) return Boolean is <>;
7777 -- package Inner_G is
7778 -- function "<" (L, R: T) return Boolean is (Compare (L, R));
7781 -- If G is instantiated on the same actual type with a single Compare
7785 -- function Compare (L, R : T) return Boolean;
7786 -- package My_G is new (T, T);
7788 -- then the renaming generated for Compare in the inner instantiation
7789 -- is ambiguous: it can rename either of the renamings generated for
7790 -- the outer instantiation. Now if the first one is picked up, then
7791 -- the subtypes of the formal parameters of the renaming will not be
7792 -- preserved in Inherit_Renamed_Profile because they are subtypes of
7793 -- the Bound_T formal type and not of the Item_T formal type, so we
7794 -- need to arrange for the second one to be picked up instead.
7796 while Present
(New_F
) loop
7797 if Etype
(Old1_F
) /= Etype
(Old2_F
) then
7798 Anc_T
:= Ancestor_Subtype
(Etype
(New_F
));
7800 if Etype
(Old1_F
) = Anc_T
then
7802 elsif Etype
(Old2_F
) = Anc_T
then
7807 Next_Formal
(New_F
);
7808 Next_Formal
(Old1_F
);
7809 Next_Formal
(Old2_F
);
7812 pragma Assert
(No
(Old1_F
));
7813 pragma Assert
(No
(Old2_F
));
7816 end Find_Nearer_Entity
;
7818 --------------------------
7819 -- Is_Visible_Operation --
7820 --------------------------
7822 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean is
7828 if Ekind
(Op
) /= E_Operator
7829 or else Scope
(Op
) /= Standard_Standard
7830 or else (In_Instance
7831 and then (not Is_Actual
7832 or else Present
(Enclosing_Instance
)))
7837 -- For a fixed point type operator, check the resulting type,
7838 -- because it may be a mixed mode integer * fixed operation.
7840 if Present
(Next_Formal
(First_Formal
(New_S
)))
7841 and then Is_Fixed_Point_Type
(Etype
(New_S
))
7843 Typ
:= Etype
(New_S
);
7845 Typ
:= Etype
(First_Formal
(New_S
));
7848 Btyp
:= Base_Type
(Typ
);
7850 if Nkind
(Nam
) /= N_Expanded_Name
then
7851 return (In_Open_Scopes
(Scope
(Btyp
))
7852 or else Is_Potentially_Use_Visible
(Btyp
)
7853 or else In_Use
(Btyp
)
7854 or else In_Use
(Scope
(Btyp
)));
7857 Scop
:= Entity
(Prefix
(Nam
));
7859 if Ekind
(Scop
) = E_Package
7860 and then Present
(Renamed_Entity
(Scop
))
7862 Scop
:= Renamed_Entity
(Scop
);
7865 -- Operator is visible if prefix of expanded name denotes
7866 -- scope of type, or else type is defined in System_Aux
7867 -- and the prefix denotes System.
7869 return Scope
(Btyp
) = Scop
7870 or else (Scope
(Btyp
) = System_Aux_Id
7871 and then Scope
(Scope
(Btyp
)) = Scop
);
7874 end Is_Visible_Operation
;
7880 function Within
(Inner
, Outer
: Entity_Id
) return Boolean is
7884 Sc
:= Scope
(Inner
);
7885 while Sc
/= Standard_Standard
loop
7896 ---------------------
7897 -- Report_Overload --
7898 ---------------------
7900 function Report_Overload
return Entity_Id
is
7903 Error_Msg_NE
-- CODEFIX
7904 ("ambiguous actual subprogram&, " &
7905 "possible interpretations:", N
, Nam
);
7907 Error_Msg_N
-- CODEFIX
7908 ("ambiguous subprogram, " &
7909 "possible interpretations:", N
);
7912 List_Interps
(Nam
, N
);
7914 end Report_Overload
;
7916 -- Start of processing for Find_Renamed_Entity
7920 Candidate_Renaming
:= Empty
;
7922 if Is_Overloaded
(Nam
) then
7923 Get_First_Interp
(Nam
, Ind
, It
);
7924 while Present
(It
.Nam
) loop
7925 if Entity_Matches_Spec
(It
.Nam
, New_S
)
7926 and then Is_Visible_Operation
(It
.Nam
)
7928 if Old_S
/= Any_Id
then
7930 -- Note: The call to Disambiguate only happens if a
7931 -- previous interpretation was found, in which case I1
7932 -- has received a value.
7934 It1
:= Disambiguate
(Nam
, I1
, Ind
, Etype
(Old_S
));
7936 if It1
= No_Interp
then
7937 Inst
:= Enclosing_Instance
;
7939 if Present
(Inst
) then
7940 if Within
(It
.Nam
, Inst
) then
7941 if Within
(Old_S
, Inst
) then
7943 It_D
: constant Uint
:=
7944 Scope_Depth_Default_0
(It
.Nam
);
7945 Old_D
: constant Uint
:=
7946 Scope_Depth_Default_0
(Old_S
);
7949 -- Choose the innermost subprogram, which
7950 -- would hide the outer one in the generic.
7952 if Old_D
> It_D
then
7954 elsif It_D
> Old_D
then
7958 -- Otherwise, if we can determine that one
7959 -- of the entities is nearer to the renaming
7960 -- than the other, choose it. If not, then
7961 -- return the newer one as done historically.
7964 Find_Nearer_Entity
(New_S
, Old_S
, It
.Nam
);
7965 if Present
(N_Ent
) then
7973 elsif Within
(Old_S
, Inst
) then
7977 return Report_Overload
;
7980 -- If not within an instance, ambiguity is real
7983 return Report_Overload
;
7997 Present
(First_Formal
(It
.Nam
))
7998 and then Present
(First_Formal
(New_S
))
7999 and then Base_Type
(Etype
(First_Formal
(It
.Nam
))) =
8000 Base_Type
(Etype
(First_Formal
(New_S
)))
8002 Candidate_Renaming
:= It
.Nam
;
8005 Get_Next_Interp
(Ind
, It
);
8008 Set_Entity
(Nam
, Old_S
);
8010 if Old_S
/= Any_Id
then
8011 Set_Is_Overloaded
(Nam
, False);
8014 -- Non-overloaded case
8018 and then Present
(Enclosing_Instance
)
8019 and then Entity_Matches_Spec
(Entity
(Nam
), New_S
)
8021 Old_S
:= Entity
(Nam
);
8023 elsif Entity_Matches_Spec
(Entity
(Nam
), New_S
) then
8024 Candidate_Renaming
:= New_S
;
8026 if Is_Visible_Operation
(Entity
(Nam
)) then
8027 Old_S
:= Entity
(Nam
);
8030 elsif Present
(First_Formal
(Entity
(Nam
)))
8031 and then Present
(First_Formal
(New_S
))
8032 and then Base_Type
(Etype
(First_Formal
(Entity
(Nam
)))) =
8033 Base_Type
(Etype
(First_Formal
(New_S
)))
8035 Candidate_Renaming
:= Entity
(Nam
);
8040 end Find_Renamed_Entity
;
8042 -----------------------------
8043 -- Find_Selected_Component --
8044 -----------------------------
8046 procedure Find_Selected_Component
(N
: Node_Id
) is
8047 P
: constant Node_Id
:= Prefix
(N
);
8050 -- Entity denoted by prefix
8057 function Available_Subtype
return Boolean;
8058 -- A small optimization: if the prefix is constrained and the component
8059 -- is an array type we may already have a usable subtype for it, so we
8060 -- can use it rather than generating a new one, because the bounds
8061 -- will be the values of the discriminants and not discriminant refs.
8062 -- This simplifies value tracing in GNATprove. For consistency, both
8063 -- the entity name and the subtype come from the constrained component.
8065 -- This is only used in GNATprove mode: when generating code it may be
8066 -- necessary to create an itype in the scope of use of the selected
8067 -- component, e.g. in the context of a expanded record equality.
8069 function Is_Reference_In_Subunit
return Boolean;
8070 -- In a subunit, the scope depth is not a proper measure of hiding,
8071 -- because the context of the proper body may itself hide entities in
8072 -- parent units. This rare case requires inspecting the tree directly
8073 -- because the proper body is inserted in the main unit and its context
8074 -- is simply added to that of the parent.
8076 -----------------------
8077 -- Available_Subtype --
8078 -----------------------
8080 function Available_Subtype
return Boolean is
8084 if GNATprove_Mode
then
8085 Comp
:= First_Entity
(Etype
(P
));
8086 while Present
(Comp
) loop
8087 if Chars
(Comp
) = Chars
(Selector_Name
(N
)) then
8088 Set_Etype
(N
, Etype
(Comp
));
8089 Set_Entity
(Selector_Name
(N
), Comp
);
8090 Set_Etype
(Selector_Name
(N
), Etype
(Comp
));
8094 Next_Component
(Comp
);
8099 end Available_Subtype
;
8101 -----------------------------
8102 -- Is_Reference_In_Subunit --
8103 -----------------------------
8105 function Is_Reference_In_Subunit
return Boolean is
8107 Comp_Unit
: Node_Id
;
8111 while Present
(Comp_Unit
)
8112 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
8114 Comp_Unit
:= Parent
(Comp_Unit
);
8117 if No
(Comp_Unit
) or else Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
8121 -- Now check whether the package is in the context of the subunit
8123 Clause
:= First
(Context_Items
(Comp_Unit
));
8124 while Present
(Clause
) loop
8125 if Nkind
(Clause
) = N_With_Clause
8126 and then Entity
(Name
(Clause
)) = P_Name
8135 end Is_Reference_In_Subunit
;
8137 -- Start of processing for Find_Selected_Component
8142 if Nkind
(P
) = N_Error
then
8146 -- If the selector already has an entity, the node has been constructed
8147 -- in the course of expansion, and is known to be valid. Do not verify
8148 -- that it is defined for the type (it may be a private component used
8149 -- in the expansion of record equality).
8151 if Present
(Entity
(Selector_Name
(N
))) then
8152 if No
(Etype
(N
)) or else Etype
(N
) = Any_Type
then
8154 Sel_Name
: constant Node_Id
:= Selector_Name
(N
);
8155 Selector
: constant Entity_Id
:= Entity
(Sel_Name
);
8159 Set_Etype
(Sel_Name
, Etype
(Selector
));
8161 if not Is_Entity_Name
(P
) then
8165 -- Build an actual subtype except for the first parameter
8166 -- of an init proc, where this actual subtype is by
8167 -- definition incorrect, since the object is uninitialized
8168 -- (and does not even have defined discriminants etc.)
8170 if Is_Entity_Name
(P
)
8171 and then Ekind
(Entity
(P
)) = E_Function
8173 Nam
:= New_Copy
(P
);
8175 if Is_Overloaded
(P
) then
8176 Save_Interps
(P
, Nam
);
8179 Rewrite
(P
, Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
8181 Analyze_Selected_Component
(N
);
8184 elsif Ekind
(Selector
) = E_Component
8185 and then (not Is_Entity_Name
(P
)
8186 or else Chars
(Entity
(P
)) /= Name_uInit
)
8188 -- Check if we already have an available subtype we can use
8190 if Ekind
(Etype
(P
)) = E_Record_Subtype
8191 and then Nkind
(Parent
(Etype
(P
))) = N_Subtype_Declaration
8192 and then Is_Array_Type
(Etype
(Selector
))
8193 and then not Is_Packed
(Etype
(Selector
))
8194 and then Available_Subtype
8198 -- Do not build the subtype when referencing components of
8199 -- dispatch table wrappers. Required to avoid generating
8200 -- elaboration code with HI runtimes.
8202 elsif Is_RTE
(Scope
(Selector
), RE_Dispatch_Table_Wrapper
)
8204 Is_RTE
(Scope
(Selector
), RE_No_Dispatch_Table_Wrapper
)
8209 Build_Actual_Subtype_Of_Component
8210 (Etype
(Selector
), N
);
8217 if No
(C_Etype
) then
8218 C_Etype
:= Etype
(Selector
);
8220 Insert_Action
(N
, C_Etype
);
8221 C_Etype
:= Defining_Identifier
(C_Etype
);
8224 Set_Etype
(N
, C_Etype
);
8227 -- If the selected component appears within a default expression
8228 -- and it has an actual subtype, the preanalysis has not yet
8229 -- completed its analysis, because Insert_Actions is disabled in
8230 -- that context. Within the init proc of the enclosing type we
8231 -- must complete this analysis, if an actual subtype was created.
8233 elsif Inside_Init_Proc
then
8235 Typ
: constant Entity_Id
:= Etype
(N
);
8236 Decl
: constant Node_Id
:= Declaration_Node
(Typ
);
8238 if Nkind
(Decl
) = N_Subtype_Declaration
8239 and then not Analyzed
(Decl
)
8240 and then Is_List_Member
(Decl
)
8241 and then No
(Parent
(Decl
))
8244 Insert_Action
(N
, Decl
);
8251 elsif Is_Entity_Name
(P
) then
8252 P_Name
:= Entity
(P
);
8254 -- The prefix may denote an enclosing type which is the completion
8255 -- of an incomplete type declaration.
8257 if Is_Type
(P_Name
) then
8258 Set_Entity
(P
, Get_Full_View
(P_Name
));
8259 Set_Etype
(P
, Entity
(P
));
8260 P_Name
:= Entity
(P
);
8263 P_Type
:= Base_Type
(Etype
(P
));
8265 if Debug_Flag_E
then
8266 Write_Str
("Found prefix type to be ");
8267 Write_Entity_Info
(P_Type
, " "); Write_Eol
;
8270 -- If the prefix's type is an access type, get to the record type
8272 if Is_Access_Type
(P_Type
) then
8273 P_Type
:= Implicitly_Designated_Type
(P_Type
);
8276 -- First check for components of a record object (not the result of
8277 -- a call, which is handled below). This also covers the case where
8278 -- the extension feature that supports the prefixed form of calls
8279 -- for primitives of untagged types is enabled (excluding concurrent
8280 -- cases, which are handled further below).
8283 and then (Has_Components
(P_Type
)
8284 or else (Core_Extensions_Allowed
8285 and then not Is_Concurrent_Type
(P_Type
)))
8286 and then not Is_Overloadable
(P_Name
)
8287 and then not Is_Type
(P_Name
)
8289 -- Selected component of record. Type checking will validate
8290 -- name of selector.
8292 -- ??? Could we rewrite an implicit dereference into an explicit
8295 Analyze_Selected_Component
(N
);
8297 -- Reference to type name in predicate/invariant expression
8299 elsif Is_Concurrent_Type
(P_Type
)
8300 and then not In_Open_Scopes
(P_Name
)
8301 and then (not Is_Concurrent_Type
(Etype
(P_Name
))
8302 or else not In_Open_Scopes
(Etype
(P_Name
)))
8304 -- Call to protected operation or entry. Type checking is
8305 -- needed on the prefix.
8307 Analyze_Selected_Component
(N
);
8309 elsif (In_Open_Scopes
(P_Name
)
8310 and then Ekind
(P_Name
) /= E_Void
8311 and then not Is_Overloadable
(P_Name
))
8312 or else (Is_Concurrent_Type
(Etype
(P_Name
))
8313 and then In_Open_Scopes
(Etype
(P_Name
)))
8315 -- Prefix denotes an enclosing loop, block, or task, i.e. an
8316 -- enclosing construct that is not a subprogram or accept.
8318 -- A special case: a protected body may call an operation
8319 -- on an external object of the same type, in which case it
8320 -- is not an expanded name. If the prefix is the type itself,
8321 -- or the context is a single synchronized object it can only
8322 -- be interpreted as an expanded name.
8324 if Is_Concurrent_Type
(Etype
(P_Name
)) then
8326 or else Present
(Anonymous_Object
(Etype
(P_Name
)))
8328 Find_Expanded_Name
(N
);
8331 Analyze_Selected_Component
(N
);
8336 Find_Expanded_Name
(N
);
8339 elsif Ekind
(P_Name
) = E_Package
then
8340 Find_Expanded_Name
(N
);
8342 elsif Is_Overloadable
(P_Name
) then
8344 -- The subprogram may be a renaming (of an enclosing scope) as
8345 -- in the case of the name of the generic within an instantiation.
8347 if Ekind
(P_Name
) in E_Procedure | E_Function
8348 and then Present
(Alias
(P_Name
))
8349 and then Is_Generic_Instance
(Alias
(P_Name
))
8351 P_Name
:= Alias
(P_Name
);
8354 if Is_Overloaded
(P
) then
8356 -- The prefix must resolve to a unique enclosing construct
8359 Found
: Boolean := False;
8364 Get_First_Interp
(P
, Ind
, It
);
8365 while Present
(It
.Nam
) loop
8366 if In_Open_Scopes
(It
.Nam
) then
8369 "prefix must be unique enclosing scope", N
);
8370 Set_Entity
(N
, Any_Id
);
8371 Set_Etype
(N
, Any_Type
);
8380 Get_Next_Interp
(Ind
, It
);
8385 if In_Open_Scopes
(P_Name
) then
8386 Set_Entity
(P
, P_Name
);
8387 Set_Is_Overloaded
(P
, False);
8388 Find_Expanded_Name
(N
);
8391 -- If no interpretation as an expanded name is possible, it
8392 -- must be a selected component of a record returned by a
8393 -- function call. Reformat prefix as a function call, the rest
8394 -- is done by type resolution.
8396 -- Error if the prefix is procedure or entry, as is P.X
8398 if Ekind
(P_Name
) /= E_Function
8400 (not Is_Overloaded
(P
)
8401 or else Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
)
8403 -- Prefix may mention a package that is hidden by a local
8404 -- declaration: let the user know. Scan the full homonym
8405 -- chain, the candidate package may be anywhere on it.
8407 if Present
(Homonym
(Current_Entity
(P_Name
))) then
8408 P_Name
:= Current_Entity
(P_Name
);
8410 while Present
(P_Name
) loop
8411 exit when Ekind
(P_Name
) = E_Package
;
8412 P_Name
:= Homonym
(P_Name
);
8415 if Present
(P_Name
) then
8416 if not Is_Reference_In_Subunit
then
8417 Error_Msg_Sloc
:= Sloc
(Entity
(Prefix
(N
)));
8419 ("package& is hidden by declaration#", N
, P_Name
);
8422 Set_Entity
(Prefix
(N
), P_Name
);
8423 Find_Expanded_Name
(N
);
8427 P_Name
:= Entity
(Prefix
(N
));
8432 ("invalid prefix in selected component&", N
, P_Name
);
8433 Change_Selected_Component_To_Expanded_Name
(N
);
8434 Set_Entity
(N
, Any_Id
);
8435 Set_Etype
(N
, Any_Type
);
8437 -- Here we have a function call, so do the reformatting
8440 Nam
:= New_Copy
(P
);
8441 Save_Interps
(P
, Nam
);
8443 -- We use Replace here because this is one of those cases
8444 -- where the parser has missclassified the node, and we fix
8445 -- things up and then do the semantic analysis on the fixed
8446 -- up node. Normally we do this using one of the Sinfo.CN
8447 -- routines, but this is too tricky for that.
8449 -- Note that using Rewrite would be wrong, because we would
8450 -- have a tree where the original node is unanalyzed.
8453 Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
8455 -- Now analyze the reformatted node
8459 -- If the prefix is illegal after this transformation, there
8460 -- may be visibility errors on the prefix. The safest is to
8461 -- treat the selected component as an error.
8463 if Error_Posted
(P
) then
8464 Set_Etype
(N
, Any_Type
);
8468 Analyze_Selected_Component
(N
);
8473 -- Remaining cases generate various error messages
8476 -- Format node as expanded name, to avoid cascaded errors
8478 Change_Selected_Component_To_Expanded_Name
(N
);
8479 Set_Entity
(N
, Any_Id
);
8480 Set_Etype
(N
, Any_Type
);
8482 -- Issue error message, but avoid this if error issued already.
8483 -- Use identifier of prefix if one is available.
8485 if P_Name
= Any_Id
then
8488 -- It is not an error if the prefix is the current instance of
8489 -- type name, e.g. the expression of a type aspect, when it is
8490 -- analyzed within a generic unit. We still have to verify that a
8491 -- component of that name exists, and decorate the node
8494 elsif Is_Entity_Name
(P
) and then Is_Current_Instance
(P
) then
8499 Comp
:= First_Entity
(Entity
(P
));
8500 while Present
(Comp
) loop
8501 if Chars
(Comp
) = Chars
(Selector_Name
(N
)) then
8502 Set_Entity
(N
, Comp
);
8503 Set_Etype
(N
, Etype
(Comp
));
8504 Set_Entity
(Selector_Name
(N
), Comp
);
8505 Set_Etype
(Selector_Name
(N
), Etype
(Comp
));
8513 elsif Is_Self_Hidden
(P_Name
) then
8514 Premature_Usage
(P
);
8516 elsif Ekind
(P_Name
) = E_Generic_Package
then
8517 Error_Msg_N
("prefix must not be a generic package", N
);
8518 Error_Msg_N
("\use package instantiation as prefix instead", N
);
8520 elsif Nkind
(P
) /= N_Attribute_Reference
then
8522 -- This may have been meant as a prefixed call to a primitive
8523 -- of an untagged type. If it is a function call check type of
8524 -- its first formal and add explanation.
8527 F
: constant Entity_Id
:=
8528 Current_Entity
(Selector_Name
(N
));
8531 and then Is_Overloadable
(F
)
8532 and then Present
(First_Entity
(F
))
8533 and then not Is_Tagged_Type
(Etype
(First_Entity
(F
)))
8536 ("prefixed call is only allowed for objects of a "
8537 & "tagged type unless -gnatX is used", N
);
8539 if not Core_Extensions_Allowed
8541 Try_Object_Operation
(N
, Allow_Extensions
=> True)
8544 ("\using -gnatX would make the prefixed call legal",
8550 Error_Msg_N
("invalid prefix in selected component&", P
);
8552 if Is_Incomplete_Type
(P_Type
)
8553 and then Is_Access_Type
(Etype
(P
))
8556 ("\dereference must not be of an incomplete type "
8557 & "(RM 3.10.1)", P
);
8561 Error_Msg_N
("invalid prefix in selected component", P
);
8565 -- If prefix is not the name of an entity, it must be an expression,
8566 -- whose type is appropriate for a record. This is determined by
8569 Analyze_Selected_Component
(N
);
8572 Analyze_Dimension
(N
);
8573 end Find_Selected_Component
;
8579 procedure Find_Type
(N
: Node_Id
) is
8589 elsif Nkind
(N
) = N_Attribute_Reference
then
8591 -- Class attribute. This is not valid in Ada 83 mode, but we do not
8592 -- need to enforce that at this point, since the declaration of the
8593 -- tagged type in the prefix would have been flagged already.
8595 if Attribute_Name
(N
) = Name_Class
then
8596 Check_Restriction
(No_Dispatch
, N
);
8597 Find_Type
(Prefix
(N
));
8599 -- Propagate error from bad prefix
8601 if Etype
(Prefix
(N
)) = Any_Type
then
8602 Set_Entity
(N
, Any_Type
);
8603 Set_Etype
(N
, Any_Type
);
8607 T
:= Base_Type
(Entity
(Prefix
(N
)));
8609 -- Case where type is not known to be tagged. Its appearance in
8610 -- the prefix of the 'Class attribute indicates that the full view
8613 if not Is_Tagged_Type
(T
) then
8614 if Ekind
(T
) = E_Incomplete_Type
then
8616 -- It is legal to denote the class type of an incomplete
8617 -- type. The full type will have to be tagged, of course.
8618 -- In Ada 2005 this usage is declared obsolescent, so we
8619 -- warn accordingly. This usage is only legal if the type
8620 -- is completed in the current scope, and not for a limited
8623 if Ada_Version
>= Ada_2005
then
8625 -- Test whether the Available_View of a limited type view
8626 -- is tagged, since the limited view may not be marked as
8627 -- tagged if the type itself has an untagged incomplete
8628 -- type view in its package.
8630 if From_Limited_With
(T
)
8631 and then not Is_Tagged_Type
(Available_View
(T
))
8634 ("prefix of Class attribute must be tagged", N
);
8635 Set_Etype
(N
, Any_Type
);
8636 Set_Entity
(N
, Any_Type
);
8640 if Restriction_Check_Required
(No_Obsolescent_Features
)
8643 (No_Obsolescent_Features
, Prefix
(N
));
8646 if Warn_On_Obsolescent_Feature
then
8648 ("applying ''Class to an untagged incomplete type"
8649 & " is an obsolescent feature (RM J.11)?r?", N
);
8654 Set_Is_Tagged_Type
(T
);
8655 Set_Direct_Primitive_Operations
(T
, New_Elmt_List
);
8656 Make_Class_Wide_Type
(T
);
8657 Set_Entity
(N
, Class_Wide_Type
(T
));
8658 Set_Etype
(N
, Class_Wide_Type
(T
));
8660 elsif Ekind
(T
) = E_Private_Type
8661 and then not Is_Generic_Type
(T
)
8662 and then In_Private_Part
(Scope
(T
))
8664 -- The Class attribute can be applied to an untagged private
8665 -- type fulfilled by a tagged type prior to the full type
8666 -- declaration (but only within the parent package's private
8667 -- part). Create the class-wide type now and check that the
8668 -- full type is tagged later during its analysis. Note that
8669 -- we do not mark the private type as tagged, unlike the
8670 -- case of incomplete types, because the type must still
8671 -- appear untagged to outside units.
8673 if No
(Class_Wide_Type
(T
)) then
8674 Make_Class_Wide_Type
(T
);
8677 Set_Entity
(N
, Class_Wide_Type
(T
));
8678 Set_Etype
(N
, Class_Wide_Type
(T
));
8681 -- Should we introduce a type Any_Tagged and use Wrong_Type
8682 -- here, it would be a bit more consistent???
8685 ("tagged type required, found}",
8686 Prefix
(N
), First_Subtype
(T
));
8687 Set_Entity
(N
, Any_Type
);
8691 -- Case of tagged type
8694 if Is_Concurrent_Type
(T
) then
8695 if No
(Corresponding_Record_Type
(Entity
(Prefix
(N
)))) then
8697 -- Previous error. Create a class-wide type for the
8698 -- synchronized type itself, with minimal semantic
8699 -- attributes, to catch other errors in some ACATS tests.
8701 pragma Assert
(Serious_Errors_Detected
/= 0);
8702 Make_Class_Wide_Type
(T
);
8703 C
:= Class_Wide_Type
(T
);
8704 Set_First_Entity
(C
, First_Entity
(T
));
8707 C
:= Class_Wide_Type
8708 (Corresponding_Record_Type
(Entity
(Prefix
(N
))));
8712 C
:= Class_Wide_Type
(Entity
(Prefix
(N
)));
8715 Set_Entity_With_Checks
(N
, C
);
8716 Generate_Reference
(C
, N
);
8720 -- Base attribute, not allowed in Ada 83
8722 elsif Attribute_Name
(N
) = Name_Base
then
8723 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
8725 ("(Ada 83) Base attribute not allowed in subtype mark", N
);
8728 Find_Type
(Prefix
(N
));
8729 Typ
:= Entity
(Prefix
(N
));
8731 if Ada_Version
>= Ada_95
8732 and then not Is_Scalar_Type
(Typ
)
8733 and then not Is_Generic_Type
(Typ
)
8736 ("prefix of Base attribute must be scalar type",
8739 elsif Warn_On_Redundant_Constructs
8740 and then Base_Type
(Typ
) = Typ
8742 Error_Msg_NE
-- CODEFIX
8743 ("redundant attribute, & is its own base type?r?", N
, Typ
);
8746 T
:= Base_Type
(Typ
);
8748 -- Rewrite attribute reference with type itself (see similar
8749 -- processing in Analyze_Attribute, case Base). Preserve prefix
8750 -- if present, for other legality checks.
8752 if Nkind
(Prefix
(N
)) = N_Expanded_Name
then
8754 Make_Expanded_Name
(Sloc
(N
),
8756 Prefix
=> New_Copy
(Prefix
(Prefix
(N
))),
8757 Selector_Name
=> New_Occurrence_Of
(T
, Sloc
(N
))));
8760 Rewrite
(N
, New_Occurrence_Of
(T
, Sloc
(N
)));
8767 elsif Attribute_Name
(N
) = Name_Stub_Type
then
8769 -- This is handled in Analyze_Attribute
8773 -- All other attributes are invalid in a subtype mark
8776 Error_Msg_N
("invalid attribute in subtype mark", N
);
8782 if Is_Entity_Name
(N
) then
8783 T_Name
:= Entity
(N
);
8785 Error_Msg_N
("subtype mark required in this context", N
);
8786 Set_Etype
(N
, Any_Type
);
8790 if T_Name
= Any_Id
or else Etype
(N
) = Any_Type
then
8792 -- Undefined id. Make it into a valid type
8794 Set_Entity
(N
, Any_Type
);
8796 elsif not Is_Type
(T_Name
)
8797 and then T_Name
/= Standard_Void_Type
8799 Error_Msg_Sloc
:= Sloc
(T_Name
);
8800 Error_Msg_N
("subtype mark required in this context", N
);
8801 Error_Msg_NE
("\\found & declared#", N
, T_Name
);
8802 Set_Entity
(N
, Any_Type
);
8805 -- If the type is an incomplete type created to handle
8806 -- anonymous access components of a record type, then the
8807 -- incomplete type is the visible entity and subsequent
8808 -- references will point to it. Mark the original full
8809 -- type as referenced, to prevent spurious warnings.
8811 if Is_Incomplete_Type
(T_Name
)
8812 and then Present
(Full_View
(T_Name
))
8813 and then not Comes_From_Source
(T_Name
)
8815 Set_Referenced
(Full_View
(T_Name
));
8818 T_Name
:= Get_Full_View
(T_Name
);
8820 -- Ada 2005 (AI-251, AI-50217): Handle interfaces visible through
8821 -- limited-with clauses
8823 if From_Limited_With
(T_Name
)
8824 and then Is_Incomplete_Type
(T_Name
)
8825 and then Present
(Non_Limited_View
(T_Name
))
8826 and then Is_Interface
(Non_Limited_View
(T_Name
))
8828 T_Name
:= Non_Limited_View
(T_Name
);
8831 if In_Open_Scopes
(T_Name
) then
8832 if Ekind
(Base_Type
(T_Name
)) = E_Task_Type
then
8834 -- In Ada 2005, a task name can be used in an access
8835 -- definition within its own body.
8837 if Ada_Version
>= Ada_2005
8838 and then Nkind
(Parent
(N
)) = N_Access_Definition
8840 Set_Entity
(N
, T_Name
);
8841 Set_Etype
(N
, T_Name
);
8846 ("task type cannot be used as type mark " &
8847 "within its own spec or body", N
);
8850 elsif Ekind
(Base_Type
(T_Name
)) = E_Protected_Type
then
8852 -- In Ada 2005, a protected name can be used in an access
8853 -- definition within its own body.
8855 if Ada_Version
>= Ada_2005
8856 and then Nkind
(Parent
(N
)) = N_Access_Definition
8858 Set_Entity
(N
, T_Name
);
8859 Set_Etype
(N
, T_Name
);
8864 ("protected type cannot be used as type mark " &
8865 "within its own spec or body", N
);
8869 Error_Msg_N
("type declaration cannot refer to itself", N
);
8872 Set_Etype
(N
, Any_Type
);
8873 Set_Entity
(N
, Any_Type
);
8874 Set_Error_Posted
(T_Name
);
8878 Set_Entity
(N
, T_Name
);
8879 Set_Etype
(N
, T_Name
);
8883 if Present
(Etype
(N
)) and then Comes_From_Source
(N
) then
8884 if Is_Fixed_Point_Type
(Etype
(N
)) then
8885 Check_Restriction
(No_Fixed_Point
, N
);
8886 elsif Is_Floating_Point_Type
(Etype
(N
)) then
8887 Check_Restriction
(No_Floating_Point
, N
);
8890 -- A Ghost type must appear in a specific context
8892 if Is_Ghost_Entity
(Etype
(N
)) then
8893 Check_Ghost_Context
(Etype
(N
), N
);
8898 --------------------
8899 -- Has_Components --
8900 --------------------
8902 function Has_Components
(Typ
: Entity_Id
) return Boolean is
8904 return Is_Record_Type
(Typ
)
8905 or else (Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
))
8906 or else (Is_Task_Type
(Typ
) and then Has_Discriminants
(Typ
))
8907 or else (Is_Incomplete_Type
(Typ
)
8908 and then From_Limited_With
(Typ
)
8909 and then Is_Record_Type
(Available_View
(Typ
)));
8912 ------------------------------------
8913 -- Has_Implicit_Character_Literal --
8914 ------------------------------------
8916 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean is
8918 Found
: Boolean := False;
8919 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
8920 Priv_Id
: Entity_Id
:= Empty
;
8923 if Ekind
(P
) = E_Package
and then not In_Open_Scopes
(P
) then
8924 Priv_Id
:= First_Private_Entity
(P
);
8927 if P
= Standard_Standard
then
8928 Change_Selected_Component_To_Expanded_Name
(N
);
8929 Rewrite
(N
, Selector_Name
(N
));
8931 Set_Etype
(Original_Node
(N
), Standard_Character
);
8935 Id
:= First_Entity
(P
);
8936 while Present
(Id
) and then Id
/= Priv_Id
loop
8937 if Is_Standard_Character_Type
(Id
) and then Is_Base_Type
(Id
) then
8939 -- We replace the node with the literal itself, resolve as a
8940 -- character, and set the type correctly.
8943 Change_Selected_Component_To_Expanded_Name
(N
);
8944 Rewrite
(N
, Selector_Name
(N
));
8947 Set_Etype
(Original_Node
(N
), Id
);
8951 -- More than one type derived from Character in given scope.
8952 -- Collect all possible interpretations.
8954 Add_One_Interp
(N
, Id
, Id
);
8962 end Has_Implicit_Character_Literal
;
8964 ----------------------
8965 -- Has_Private_With --
8966 ----------------------
8968 function Has_Private_With
(E
: Entity_Id
) return Boolean is
8969 Comp_Unit
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
8973 Item
:= First
(Context_Items
(Comp_Unit
));
8974 while Present
(Item
) loop
8975 if Nkind
(Item
) = N_With_Clause
8976 and then Private_Present
(Item
)
8977 and then Entity
(Name
(Item
)) = E
8986 end Has_Private_With
;
8988 ---------------------------
8989 -- Has_Implicit_Operator --
8990 ---------------------------
8992 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean is
8993 Op_Id
: constant Name_Id
:= Chars
(Selector_Name
(N
));
8994 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
8996 Priv_Id
: Entity_Id
:= Empty
;
8998 procedure Add_Implicit_Operator
9000 Op_Type
: Entity_Id
:= Empty
);
9001 -- Add implicit interpretation to node N, using the type for which a
9002 -- predefined operator exists. If the operator yields a boolean type,
9003 -- the Operand_Type is implicitly referenced by the operator, and a
9004 -- reference to it must be generated.
9006 ---------------------------
9007 -- Add_Implicit_Operator --
9008 ---------------------------
9010 procedure Add_Implicit_Operator
9012 Op_Type
: Entity_Id
:= Empty
)
9014 Predef_Op
: Entity_Id
;
9017 Predef_Op
:= Current_Entity
(Selector_Name
(N
));
9018 while Present
(Predef_Op
)
9019 and then Scope
(Predef_Op
) /= Standard_Standard
9021 Predef_Op
:= Homonym
(Predef_Op
);
9024 if Nkind
(N
) = N_Selected_Component
then
9025 Change_Selected_Component_To_Expanded_Name
(N
);
9028 -- If the context is an unanalyzed function call, determine whether
9029 -- a binary or unary interpretation is required.
9031 if Nkind
(Parent
(N
)) = N_Indexed_Component
then
9033 Is_Binary_Call
: constant Boolean :=
9035 (Next
(First
(Expressions
(Parent
(N
)))));
9036 Is_Binary_Op
: constant Boolean :=
9038 (Predef_Op
) /= Last_Entity
(Predef_Op
);
9039 Predef_Op2
: constant Entity_Id
:= Homonym
(Predef_Op
);
9042 if Is_Binary_Call
then
9043 if Is_Binary_Op
then
9044 Add_One_Interp
(N
, Predef_Op
, T
);
9046 Add_One_Interp
(N
, Predef_Op2
, T
);
9049 if not Is_Binary_Op
then
9050 Add_One_Interp
(N
, Predef_Op
, T
);
9052 -- Predef_Op2 may be empty in case of previous errors
9054 elsif Present
(Predef_Op2
) then
9055 Add_One_Interp
(N
, Predef_Op2
, T
);
9061 Add_One_Interp
(N
, Predef_Op
, T
);
9063 -- For operators with unary and binary interpretations, if
9064 -- context is not a call, add both
9066 if Present
(Homonym
(Predef_Op
)) then
9067 Add_One_Interp
(N
, Homonym
(Predef_Op
), T
);
9071 -- The node is a reference to a predefined operator, and
9072 -- an implicit reference to the type of its operands.
9074 if Present
(Op_Type
) then
9075 Generate_Operator_Reference
(N
, Op_Type
);
9077 Generate_Operator_Reference
(N
, T
);
9079 end Add_Implicit_Operator
;
9081 -- Start of processing for Has_Implicit_Operator
9084 if Ekind
(P
) = E_Package
and then not In_Open_Scopes
(P
) then
9085 Priv_Id
:= First_Private_Entity
(P
);
9088 Id
:= First_Entity
(P
);
9092 -- Boolean operators: an implicit declaration exists if the scope
9093 -- contains a declaration for a derived Boolean type, or for an
9094 -- array of Boolean type.
9101 while Id
/= Priv_Id
loop
9103 and then Valid_Boolean_Arg
(Id
)
9104 and then Is_Base_Type
(Id
)
9106 Add_Implicit_Operator
(Id
);
9113 -- Equality: look for any non-limited type (result is Boolean)
9118 while Id
/= Priv_Id
loop
9120 and then Valid_Equality_Arg
(Id
)
9121 and then Is_Base_Type
(Id
)
9123 Add_Implicit_Operator
(Standard_Boolean
, Id
);
9130 -- Comparison operators: scalar type, or array of scalar
9137 while Id
/= Priv_Id
loop
9139 and then Valid_Comparison_Arg
(Id
)
9140 and then Is_Base_Type
(Id
)
9142 Add_Implicit_Operator
(Standard_Boolean
, Id
);
9149 -- Arithmetic operators: any numeric type
9160 while Id
/= Priv_Id
loop
9161 if Is_Numeric_Type
(Id
) and then Is_Base_Type
(Id
) then
9162 Add_Implicit_Operator
(Id
);
9169 -- Concatenation: any one-dimensional array type
9171 when Name_Op_Concat
=>
9172 while Id
/= Priv_Id
loop
9173 if Is_Array_Type
(Id
)
9174 and then Number_Dimensions
(Id
) = 1
9175 and then Is_Base_Type
(Id
)
9177 Add_Implicit_Operator
(Id
);
9184 -- What is the others condition here? Should we be using a
9185 -- subtype of Name_Id that would restrict to operators ???
9191 -- If we fall through, then we do not have an implicit operator
9194 end Has_Implicit_Operator
;
9196 -----------------------------------
9197 -- Has_Loop_In_Inner_Open_Scopes --
9198 -----------------------------------
9200 function Has_Loop_In_Inner_Open_Scopes
(S
: Entity_Id
) return Boolean is
9202 -- Several scope stacks are maintained by Scope_Stack. The base of the
9203 -- currently active scope stack is denoted by the Is_Active_Stack_Base
9204 -- flag in the scope stack entry. Note that the scope stacks used to
9205 -- simply be delimited implicitly by the presence of Standard_Standard
9206 -- at their base, but there now are cases where this is not sufficient
9207 -- because Standard_Standard actually may appear in the middle of the
9208 -- active set of scopes.
9210 for J
in reverse 0 .. Scope_Stack
.Last
loop
9212 -- S was reached without seing a loop scope first
9214 if Scope_Stack
.Table
(J
).Entity
= S
then
9217 -- S was not yet reached, so it contains at least one inner loop
9219 elsif Ekind
(Scope_Stack
.Table
(J
).Entity
) = E_Loop
then
9223 -- Check Is_Active_Stack_Base to tell us when to stop, as there are
9224 -- cases where Standard_Standard appears in the middle of the active
9225 -- set of scopes. This affects the declaration and overriding of
9226 -- private inherited operations in instantiations of generic child
9229 pragma Assert
(not Scope_Stack
.Table
(J
).Is_Active_Stack_Base
);
9232 raise Program_Error
; -- unreachable
9233 end Has_Loop_In_Inner_Open_Scopes
;
9235 --------------------
9236 -- In_Open_Scopes --
9237 --------------------
9239 function In_Open_Scopes
(S
: Entity_Id
) return Boolean is
9241 -- Several scope stacks are maintained by Scope_Stack. The base of the
9242 -- currently active scope stack is denoted by the Is_Active_Stack_Base
9243 -- flag in the scope stack entry. Note that the scope stacks used to
9244 -- simply be delimited implicitly by the presence of Standard_Standard
9245 -- at their base, but there now are cases where this is not sufficient
9246 -- because Standard_Standard actually may appear in the middle of the
9247 -- active set of scopes.
9249 for J
in reverse 0 .. Scope_Stack
.Last
loop
9250 if Scope_Stack
.Table
(J
).Entity
= S
then
9254 -- Check Is_Active_Stack_Base to tell us when to stop, as there are
9255 -- cases where Standard_Standard appears in the middle of the active
9256 -- set of scopes. This affects the declaration and overriding of
9257 -- private inherited operations in instantiations of generic child
9260 exit when Scope_Stack
.Table
(J
).Is_Active_Stack_Base
;
9266 -----------------------------
9267 -- Inherit_Renamed_Profile --
9268 -----------------------------
9270 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
) is
9277 if Ekind
(Old_S
) = E_Operator
then
9278 New_F
:= First_Formal
(New_S
);
9280 while Present
(New_F
) loop
9281 Set_Etype
(New_F
, Base_Type
(Etype
(New_F
)));
9282 Next_Formal
(New_F
);
9285 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
9288 New_F
:= First_Formal
(New_S
);
9289 Old_F
:= First_Formal
(Old_S
);
9291 while Present
(New_F
) loop
9292 New_T
:= Etype
(New_F
);
9293 Old_T
:= Etype
(Old_F
);
9295 -- If the new type is a renaming of the old one, as is the case
9296 -- for actuals in instances, retain its name, to simplify later
9299 if Nkind
(Parent
(New_T
)) = N_Subtype_Declaration
9300 and then Is_Entity_Name
(Subtype_Indication
(Parent
(New_T
)))
9301 and then Entity
(Subtype_Indication
(Parent
(New_T
))) = Old_T
9305 Set_Etype
(New_F
, Old_T
);
9308 Next_Formal
(New_F
);
9309 Next_Formal
(Old_F
);
9312 pragma Assert
(No
(Old_F
));
9314 if Ekind
(Old_S
) in E_Function | E_Enumeration_Literal
then
9315 Set_Etype
(New_S
, Etype
(Old_S
));
9318 end Inherit_Renamed_Profile
;
9324 procedure Initialize
is
9329 -------------------------
9330 -- Install_Use_Clauses --
9331 -------------------------
9333 procedure Install_Use_Clauses
9335 Force_Installation
: Boolean := False)
9341 while Present
(U
) loop
9343 -- Case of USE package
9345 if Nkind
(U
) = N_Use_Package_Clause
then
9346 Use_One_Package
(U
, Name
(U
), True);
9351 Use_One_Type
(Subtype_Mark
(U
), Force
=> Force_Installation
);
9355 Next_Use_Clause
(U
);
9357 end Install_Use_Clauses
;
9359 ----------------------
9360 -- Mark_Use_Clauses --
9361 ----------------------
9363 procedure Mark_Use_Clauses
(Id
: Node_Or_Entity_Id
) is
9364 procedure Mark_Parameters
(Call
: Entity_Id
);
9365 -- Perform use_type_clause marking for all parameters in a subprogram
9366 -- or operator call.
9368 procedure Mark_Use_Package
(Pak
: Entity_Id
);
9369 -- Move up the Prev_Use_Clause chain for packages denoted by Pak -
9370 -- marking each clause in the chain as effective in the process.
9372 procedure Mark_Use_Type
(E
: Entity_Id
);
9373 -- Similar to Do_Use_Package_Marking except we move up the
9374 -- Prev_Use_Clause chain for the type denoted by E.
9376 ---------------------
9377 -- Mark_Parameters --
9378 ---------------------
9380 procedure Mark_Parameters
(Call
: Entity_Id
) is
9384 -- Move through all of the formals
9386 Curr
:= First_Formal
(Call
);
9387 while Present
(Curr
) loop
9388 Mark_Use_Type
(Curr
);
9393 -- Handle the return type
9395 Mark_Use_Type
(Call
);
9396 end Mark_Parameters
;
9398 ----------------------
9399 -- Mark_Use_Package --
9400 ----------------------
9402 procedure Mark_Use_Package
(Pak
: Entity_Id
) is
9406 -- Ignore cases where the scope of the type is not a package (e.g.
9407 -- Standard_Standard).
9409 if Ekind
(Pak
) /= E_Package
then
9413 Curr
:= Current_Use_Clause
(Pak
);
9414 while Present
(Curr
)
9415 and then not Is_Effective_Use_Clause
(Curr
)
9417 -- We need to mark the previous use clauses as effective, but
9418 -- each use clause may in turn render other use_package_clauses
9419 -- effective. Additionally, it is possible to have a parent
9420 -- package renamed as a child of itself so we must check the
9421 -- prefix entity is not the same as the package we are marking.
9423 if Nkind
(Name
(Curr
)) /= N_Identifier
9424 and then Present
(Prefix
(Name
(Curr
)))
9425 and then Entity
(Prefix
(Name
(Curr
))) /= Pak
9427 Mark_Use_Package
(Entity
(Prefix
(Name
(Curr
))));
9429 -- It is also possible to have a child package without a prefix
9430 -- that relies on a previous use_package_clause.
9432 elsif Nkind
(Name
(Curr
)) = N_Identifier
9433 and then Is_Child_Unit
(Entity
(Name
(Curr
)))
9435 Mark_Use_Package
(Scope
(Entity
(Name
(Curr
))));
9438 -- Mark the use_package_clause as effective and move up the chain
9440 Set_Is_Effective_Use_Clause
(Curr
);
9442 Curr
:= Prev_Use_Clause
(Curr
);
9444 end Mark_Use_Package
;
9450 procedure Mark_Use_Type
(E
: Entity_Id
) is
9455 -- Ignore void types and unresolved string literals and primitives
9457 if Nkind
(E
) = N_String_Literal
9458 or else Nkind
(Etype
(E
)) not in N_Entity
9459 or else not Is_Type
(Etype
(E
))
9464 -- Primitives with class-wide operands might additionally render
9465 -- their base type's use_clauses effective - so do a recursive check
9468 Base
:= Base_Type
(Etype
(E
));
9470 if Ekind
(Base
) = E_Class_Wide_Type
then
9471 Mark_Use_Type
(Base
);
9474 -- The package containing the type or operator function being used
9475 -- may be in use as well, so mark any use_package_clauses for it as
9476 -- effective. There are also additional sanity checks performed here
9477 -- for ignoring previous errors.
9479 Mark_Use_Package
(Scope
(Base
));
9481 if Nkind
(E
) in N_Op
9482 and then Present
(Entity
(E
))
9483 and then Present
(Scope
(Entity
(E
)))
9485 Mark_Use_Package
(Scope
(Entity
(E
)));
9488 Curr
:= Current_Use_Clause
(Base
);
9489 while Present
(Curr
)
9490 and then not Is_Effective_Use_Clause
(Curr
)
9492 -- Current use_type_clause may render other use_package_clauses
9495 if Nkind
(Subtype_Mark
(Curr
)) /= N_Identifier
9496 and then Present
(Prefix
(Subtype_Mark
(Curr
)))
9498 Mark_Use_Package
(Entity
(Prefix
(Subtype_Mark
(Curr
))));
9501 -- Mark the use_type_clause as effective and move up the chain
9503 Set_Is_Effective_Use_Clause
(Curr
);
9505 Curr
:= Prev_Use_Clause
(Curr
);
9509 -- Start of processing for Mark_Use_Clauses
9512 -- Use clauses in and of themselves do not count as a "use" of a
9515 if Nkind
(Parent
(Id
)) in N_Use_Package_Clause | N_Use_Type_Clause
then
9521 if Nkind
(Id
) in N_Entity
then
9523 -- Mark the entity's package
9525 if Is_Potentially_Use_Visible
(Id
) then
9526 Mark_Use_Package
(Scope
(Id
));
9529 -- Mark enumeration literals
9531 if Ekind
(Id
) = E_Enumeration_Literal
then
9536 elsif (Is_Overloadable
(Id
)
9537 or else Is_Generic_Subprogram
(Id
))
9538 and then (Is_Potentially_Use_Visible
(Id
)
9539 or else Is_Intrinsic_Subprogram
(Id
)
9540 or else (Ekind
(Id
) in E_Function | E_Procedure
9541 and then Is_Generic_Actual_Subprogram
(Id
)))
9543 Mark_Parameters
(Id
);
9551 if Nkind
(Id
) in N_Op
then
9553 -- At this point the left operand may not be resolved if we are
9554 -- encountering multiple operators next to eachother in an
9557 if Nkind
(Id
) in N_Binary_Op
9558 and then not (Nkind
(Left_Opnd
(Id
)) in N_Op
)
9560 Mark_Use_Type
(Left_Opnd
(Id
));
9563 Mark_Use_Type
(Right_Opnd
(Id
));
9566 -- Mark entity identifiers
9568 elsif Nkind
(Id
) in N_Has_Entity
9569 and then (Is_Potentially_Use_Visible
(Entity
(Id
))
9570 or else (Is_Generic_Instance
(Entity
(Id
))
9571 and then Is_Immediately_Visible
(Entity
(Id
))))
9573 -- Ignore fully qualified names as they do not count as a "use" of
9576 if Nkind
(Id
) in N_Identifier | N_Operator_Symbol
9577 or else (Present
(Prefix
(Id
))
9578 and then Scope
(Entity
(Id
)) /= Entity
(Prefix
(Id
)))
9580 Mark_Use_Clauses
(Entity
(Id
));
9584 end Mark_Use_Clauses
;
9586 --------------------------------
9587 -- Most_Descendant_Use_Clause --
9588 --------------------------------
9590 function Most_Descendant_Use_Clause
9591 (Clause1
: Entity_Id
;
9592 Clause2
: Entity_Id
) return Entity_Id
9594 function Determine_Package_Scope
(Clause
: Node_Id
) return Entity_Id
;
9595 -- Given a use clause, determine which package it belongs to
9597 -----------------------------
9598 -- Determine_Package_Scope --
9599 -----------------------------
9601 function Determine_Package_Scope
(Clause
: Node_Id
) return Entity_Id
is
9603 -- Check if the clause appears in the context area
9605 -- Note we cannot employ Enclosing_Packge for use clauses within
9606 -- context clauses since they are not actually "enclosed."
9608 if Nkind
(Parent
(Clause
)) = N_Compilation_Unit
then
9609 return Entity_Of_Unit
(Unit
(Parent
(Clause
)));
9612 -- Otherwise, obtain the enclosing package normally
9614 return Enclosing_Package
(Clause
);
9615 end Determine_Package_Scope
;
9620 -- Start of processing for Most_Descendant_Use_Clause
9623 if Clause1
= Clause2
then
9627 -- We determine which one is the most descendant by the scope distance
9628 -- to the ultimate parent unit.
9630 Scope1
:= Determine_Package_Scope
(Clause1
);
9631 Scope2
:= Determine_Package_Scope
(Clause2
);
9632 while Scope1
/= Standard_Standard
9633 and then Scope2
/= Standard_Standard
9635 Scope1
:= Scope
(Scope1
);
9636 Scope2
:= Scope
(Scope2
);
9640 elsif No
(Scope2
) then
9645 if Scope1
= Standard_Standard
then
9650 end Most_Descendant_Use_Clause
;
9656 procedure Pop_Scope
is
9657 SST
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9658 S
: constant Scope_Kind_Id
:= SST
.Entity
;
9661 if Debug_Flag_E
then
9665 -- Set Default_Storage_Pool field of the library unit if necessary
9667 if Is_Package_Or_Generic_Package
(S
)
9669 Nkind
(Parent
(Unit_Declaration_Node
(S
))) = N_Compilation_Unit
9672 Aux
: constant Node_Id
:=
9673 Aux_Decls_Node
(Parent
(Unit_Declaration_Node
(S
)));
9675 if No
(Default_Storage_Pool
(Aux
)) then
9676 Set_Default_Storage_Pool
(Aux
, Default_Pool
);
9681 Scope_Suppress
:= SST
.Save_Scope_Suppress
;
9682 Local_Suppress_Stack_Top
:= SST
.Save_Local_Suppress_Stack_Top
;
9683 Check_Policy_List
:= SST
.Save_Check_Policy_List
;
9684 Default_Pool
:= SST
.Save_Default_Storage_Pool
;
9685 No_Tagged_Streams
:= SST
.Save_No_Tagged_Streams
;
9686 SPARK_Mode
:= SST
.Save_SPARK_Mode
;
9687 SPARK_Mode_Pragma
:= SST
.Save_SPARK_Mode_Pragma
;
9688 Default_SSO
:= SST
.Save_Default_SSO
;
9689 Uneval_Old
:= SST
.Save_Uneval_Old
;
9691 if Debug_Flag_W
then
9692 Write_Str
("<-- exiting scope: ");
9693 Write_Name
(Chars
(Current_Scope
));
9694 Write_Str
(", Depth=");
9695 Write_Int
(Int
(Scope_Stack
.Last
));
9699 End_Use_Clauses
(SST
.First_Use_Clause
);
9701 -- If the actions to be wrapped are still there they will get lost
9702 -- causing incomplete code to be generated. It is better to abort in
9703 -- this case (and we do the abort even with assertions off since the
9704 -- penalty is incorrect code generation).
9706 if SST
.Actions_To_Be_Wrapped
/= Scope_Actions
'(others => No_List) then
9707 raise Program_Error;
9710 -- Free last subprogram name if allocated, and pop scope
9712 Free (SST.Last_Subprogram_Name);
9713 Scope_Stack.Decrement_Last;
9720 procedure Push_Scope (S : Scope_Kind_Id) is
9721 E : constant Entity_Id := Scope (S);
9723 function Component_Alignment_Default return Component_Alignment_Kind;
9724 -- Return Component_Alignment_Kind for the newly-pushed scope.
9726 function Component_Alignment_Default return Component_Alignment_Kind is
9728 -- Each new scope pushed onto the scope stack inherits the component
9729 -- alignment of the previous scope. This emulates the "visibility"
9730 -- semantics of pragma Component_Alignment.
9732 if Scope_Stack.Last > Scope_Stack.First then
9733 return Scope_Stack.Table
9734 (Scope_Stack.Last - 1).Component_Alignment_Default;
9736 -- Otherwise, this is the first scope being pushed on the scope
9737 -- stack. Inherit the component alignment from the configuration
9738 -- form of pragma Component_Alignment (if any).
9741 return Configuration_Component_Alignment;
9743 end Component_Alignment_Default;
9746 if Ekind (S) = E_Void then
9749 -- Set scope depth if not a nonconcurrent type, and we have not yet set
9750 -- the scope depth. This means that we have the first occurrence of the
9751 -- scope, and this is where the depth is set.
9753 elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
9754 and then not Scope_Depth_Set (S)
9756 if S = Standard_Standard then
9757 Set_Scope_Depth_Value (S, Uint_0);
9759 elsif Is_Child_Unit (S) then
9760 Set_Scope_Depth_Value (S, Uint_1);
9762 elsif not Is_Record_Type (Current_Scope) then
9763 if Scope_Depth_Set (Current_Scope) then
9764 if Ekind (S) = E_Loop then
9765 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
9767 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
9773 Scope_Stack.Increment_Last;
9775 Scope_Stack.Table (Scope_Stack.Last) :=
9777 Save_Scope_Suppress => Scope_Suppress,
9778 Save_Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
9779 Save_Check_Policy_List => Check_Policy_List,
9780 Save_Default_Storage_Pool => Default_Pool,
9781 Save_No_Tagged_Streams => No_Tagged_Streams,
9782 Save_SPARK_Mode => SPARK_Mode,
9783 Save_SPARK_Mode_Pragma => SPARK_Mode_Pragma,
9784 Save_Default_SSO => Default_SSO,
9785 Save_Uneval_Old => Uneval_Old,
9786 Component_Alignment_Default => Component_Alignment_Default,
9787 Last_Subprogram_Name => null,
9788 Is_Transient => False,
9789 Node_To_Be_Wrapped => Empty,
9790 Pending_Freeze_Actions => No_List,
9791 Actions_To_Be_Wrapped => (others => No_List),
9792 First_Use_Clause => Empty,
9793 Is_Active_Stack_Base => False,
9794 Previous_Visibility => False,
9795 Locked_Shared_Objects => No_Elist);
9797 if Debug_Flag_W then
9798 Write_Str ("--> new scope: ");
9799 Write_Name (Chars (Current_Scope));
9800 Write_Str (", Id=");
9801 Write_Int (Int (Current_Scope));
9802 Write_Str (", Depth=");
9803 Write_Int (Int (Scope_Stack.Last));
9807 -- Deal with copying flags from the previous scope to this one. This is
9808 -- not necessary if either scope is standard, or if the new scope is a
9811 if S /= Standard_Standard
9812 and then Scope (S) /= Standard_Standard
9813 and then not Is_Child_Unit (S)
9815 if Nkind (E) not in N_Entity then
9819 -- Copy categorization flags from Scope (S) to S, this is not done
9820 -- when Scope (S) is Standard_Standard since propagation is from
9821 -- library unit entity inwards. Copy other relevant attributes as
9822 -- well (Discard_Names in particular).
9824 -- We only propagate inwards for library level entities,
9825 -- inner level subprograms do not inherit the categorization.
9827 if Is_Library_Level_Entity (S) then
9828 Set_Is_Preelaborated (S, Is_Preelaborated (E));
9829 Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
9830 Set_Discard_Names (S, Discard_Names (E));
9831 Set_Suppress_Value_Tracking_On_Call
9832 (S, Suppress_Value_Tracking_On_Call (E));
9833 Set_Categorization_From_Scope (E => S, Scop => E);
9837 if Is_Child_Unit (S)
9838 and then Present (E)
9839 and then Is_Package_Or_Generic_Package (E)
9841 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
9844 Aux : constant Node_Id :=
9845 Aux_Decls_Node (Parent (Unit_Declaration_Node (E)));
9847 if Present (Default_Storage_Pool (Aux)) then
9848 Default_Pool := Default_Storage_Pool (Aux);
9854 ---------------------
9855 -- Premature_Usage --
9856 ---------------------
9858 procedure Premature_Usage (N : Node_Id) is
9859 Kind : constant Node_Kind := Nkind (Parent (Entity (N)));
9860 E : Entity_Id := Entity (N);
9863 -- Within an instance, the analysis of the actual for a formal object
9864 -- does not see the name of the object itself. This is significant only
9865 -- if the object is an aggregate, where its analysis does not do any
9866 -- name resolution on component associations. (see 4717-008). In such a
9867 -- case, look for the visible homonym on the chain.
9869 if In_Instance and then Present (Homonym (E)) then
9871 while Present (E) and then not In_Open_Scopes (Scope (E)) loop
9877 Set_Etype (N, Etype (E));
9883 when N_Component_Declaration =>
9885 ("component&! cannot be used before end of record declaration",
9888 when N_Parameter_Specification =>
9890 ("formal parameter&! cannot be used before end of specification",
9893 when N_Discriminant_Specification =>
9895 ("discriminant&! cannot be used before end of discriminant part",
9898 when N_Procedure_Specification | N_Function_Specification =>
9900 ("subprogram&! cannot be used before end of its declaration",
9903 when N_Full_Type_Declaration | N_Subtype_Declaration =>
9905 ("type& cannot be used before end of its declaration!", N);
9909 ("object& cannot be used before end of its declaration!", N);
9911 -- If the premature reference appears as the expression in its own
9912 -- declaration, rewrite it to prevent compiler loops in subsequent
9913 -- uses of this mangled declaration in address clauses.
9915 if Nkind (Parent (N)) = N_Object_Declaration then
9916 Set_Entity (N, Any_Id);
9919 end Premature_Usage;
9921 ------------------------
9922 -- Present_System_Aux --
9923 ------------------------
9925 function Present_System_Aux (N : Node_Id := Empty) return Boolean is
9927 Aux_Name : Unit_Name_Type;
9928 Unum : Unit_Number_Type;
9933 function Find_System (C_Unit : Node_Id) return Entity_Id;
9934 -- Scan context clause of compilation unit to find with_clause
9941 function Find_System (C_Unit : Node_Id) return Entity_Id is
9942 With_Clause : Node_Id;
9945 With_Clause := First (Context_Items (C_Unit));
9946 while Present (With_Clause) loop
9947 if (Nkind (With_Clause) = N_With_Clause
9948 and then Chars (Name (With_Clause)) = Name_System)
9949 and then Comes_From_Source (With_Clause)
9960 -- Start of processing for Present_System_Aux
9963 -- The child unit may have been loaded and analyzed already
9965 if Present (System_Aux_Id) then
9968 -- If no previous pragma for System.Aux, nothing to load
9970 elsif No (System_Extend_Unit) then
9973 -- Use the unit name given in the pragma to retrieve the unit.
9974 -- Verify that System itself appears in the context clause of the
9975 -- current compilation. If System is not present, an error will
9976 -- have been reported already.
9979 With_Sys := Find_System (Cunit (Current_Sem_Unit));
9981 The_Unit := Unit (Cunit (Current_Sem_Unit));
9985 (Nkind (The_Unit) = N_Package_Body
9986 or else (Nkind (The_Unit) = N_Subprogram_Body
9987 and then not Acts_As_Spec (Cunit (Current_Sem_Unit))))
9989 With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit)));
9992 if No (With_Sys) and then Present (N) then
9994 -- If we are compiling a subunit, we need to examine its
9995 -- context as well (Current_Sem_Unit is the parent unit);
9997 The_Unit := Parent (N);
9998 while Nkind (The_Unit) /= N_Compilation_Unit loop
9999 The_Unit := Parent (The_Unit);
10002 if Nkind (Unit (The_Unit)) = N_Subunit then
10003 With_Sys := Find_System (The_Unit);
10007 if No (With_Sys) then
10011 Loc := Sloc (With_Sys);
10012 Get_Name_String (Chars (Expression (System_Extend_Unit)));
10013 Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
10014 Name_Buffer (1 .. 7) := "system.";
10015 Name_Buffer (Name_Len + 8) := '%';
10016 Name_Buffer (Name_Len + 9) := 's
';
10017 Name_Len := Name_Len + 9;
10018 Aux_Name := Name_Find;
10022 (Load_Name => Aux_Name,
10025 Error_Node => With_Sys);
10027 if Unum /= No_Unit then
10028 Semantics (Cunit (Unum));
10030 Defining_Entity (Specification (Unit (Cunit (Unum))));
10033 Make_With_Clause (Loc,
10035 Make_Expanded_Name (Loc,
10036 Chars => Chars (System_Aux_Id),
10038 New_Occurrence_Of (Scope (System_Aux_Id), Loc),
10039 Selector_Name => New_Occurrence_Of (System_Aux_Id, Loc)));
10041 Set_Entity (Name (Withn), System_Aux_Id);
10043 Set_Corresponding_Spec (Withn, System_Aux_Id);
10044 Set_First_Name (Withn);
10045 Set_Implicit_With (Withn);
10046 Set_Library_Unit (Withn, Cunit (Unum));
10048 Insert_After (With_Sys, Withn);
10049 Mark_Rewrite_Insertion (Withn);
10050 Set_Context_Installed (Withn);
10054 -- Here if unit load failed
10057 Error_Msg_Name_1 := Name_System;
10058 Error_Msg_Name_2 := Chars (Expression (System_Extend_Unit));
10060 ("extension package `%.%` does not exist",
10061 Opt.System_Extend_Unit);
10065 end Present_System_Aux;
10067 -------------------------
10068 -- Restore_Scope_Stack --
10069 -------------------------
10071 procedure Restore_Scope_Stack
10073 Handle_Use : Boolean := True)
10075 SS_Last : constant Int := Scope_Stack.Last;
10079 -- Restore visibility of previous scope stack, if any, using the list
10080 -- we saved (we use Remove, since this list will not be used again).
10083 Elmt := First_Elmt (List);
10084 exit when Elmt = No_Elmt;
10085 Set_Is_Immediately_Visible (Node (Elmt));
10086 Remove_Elmt (List, Elmt);
10089 -- Restore use clauses
10091 if SS_Last >= Scope_Stack.First
10092 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
10093 and then Handle_Use
10095 Install_Use_Clauses
10096 (Scope_Stack.Table (SS_Last).First_Use_Clause,
10097 Force_Installation => True);
10099 end Restore_Scope_Stack;
10101 ----------------------
10102 -- Save_Scope_Stack --
10103 ----------------------
10105 -- Save_Scope_Stack/Restore_Scope_Stack were originally designed to avoid
10106 -- consuming any memory. That is, Save_Scope_Stack took care of removing
10107 -- from immediate visibility entities and Restore_Scope_Stack took care
10108 -- of restoring their visibility analyzing the context of each entity. The
10109 -- problem of such approach is that it was fragile and caused unexpected
10110 -- visibility problems, and indeed one test was found where there was a
10113 -- Furthermore, the following experiment was carried out:
10115 -- - Save_Scope_Stack was modified to store in an Elist1 all those
10116 -- entities whose attribute Is_Immediately_Visible is modified
10117 -- from True to False.
10119 -- - Restore_Scope_Stack was modified to store in another Elist2
10120 -- all the entities whose attribute Is_Immediately_Visible is
10121 -- modified from False to True.
10123 -- - Extra code was added to verify that all the elements of Elist1
10124 -- are found in Elist2
10126 -- This test shows that there may be more occurrences of this problem which
10127 -- have not yet been detected. As a result, we replaced that approach by
10128 -- the current one in which Save_Scope_Stack returns the list of entities
10129 -- whose visibility is changed, and that list is passed to Restore_Scope_
10130 -- Stack to undo that change. This approach is simpler and safer, although
10131 -- it consumes more memory.
10133 function Save_Scope_Stack (Handle_Use : Boolean := True) return Elist_Id is
10134 Result : constant Elist_Id := New_Elmt_List;
10137 SS_Last : constant Int := Scope_Stack.Last;
10139 procedure Remove_From_Visibility (E : Entity_Id);
10140 -- If E is immediately visible then append it to the result and remove
10141 -- it temporarily from visibility.
10143 ----------------------------
10144 -- Remove_From_Visibility --
10145 ----------------------------
10147 procedure Remove_From_Visibility (E : Entity_Id) is
10149 if Is_Immediately_Visible (E) then
10150 Append_Elmt (E, Result);
10151 Set_Is_Immediately_Visible (E, False);
10153 end Remove_From_Visibility;
10155 -- Start of processing for Save_Scope_Stack
10158 if SS_Last >= Scope_Stack.First
10159 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
10162 End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
10165 -- If the call is from within a compilation unit, as when called from
10166 -- Rtsfind, make current entries in scope stack invisible while we
10167 -- analyze the new unit.
10169 for J in reverse 0 .. SS_Last loop
10170 exit when Scope_Stack.Table (J).Entity = Standard_Standard
10171 or else No (Scope_Stack.Table (J).Entity);
10173 S := Scope_Stack.Table (J).Entity;
10175 Remove_From_Visibility (S);
10177 E := First_Entity (S);
10178 while Present (E) loop
10179 Remove_From_Visibility (E);
10187 end Save_Scope_Stack;
10193 procedure Set_Use (L : List_Id) is
10198 while Present (Decl) loop
10199 if Nkind (Decl) = N_Use_Package_Clause then
10200 Chain_Use_Clause (Decl);
10201 Use_One_Package (Decl, Name (Decl));
10203 elsif Nkind (Decl) = N_Use_Type_Clause then
10204 Chain_Use_Clause (Decl);
10205 Use_One_Type (Subtype_Mark (Decl));
10213 -----------------------------
10214 -- Update_Use_Clause_Chain --
10215 -----------------------------
10217 procedure Update_Use_Clause_Chain is
10219 procedure Update_Chain_In_Scope (Level : Int);
10220 -- Iterate through one level in the scope stack verifying each use-type
10221 -- clause within said level is used then reset the Current_Use_Clause
10222 -- to a redundant use clause outside of the current ending scope if such
10223 -- a clause exists.
10225 ---------------------------
10226 -- Update_Chain_In_Scope --
10227 ---------------------------
10229 procedure Update_Chain_In_Scope (Level : Int) is
10234 -- Loop through all use clauses within the scope dictated by Level
10236 Curr := Scope_Stack.Table (Level).First_Use_Clause;
10237 while Present (Curr) loop
10239 -- Retrieve the subtype mark or name within the current current
10242 if Nkind (Curr) = N_Use_Type_Clause then
10243 N := Subtype_Mark (Curr);
10248 -- If warnings for unreferenced entities are enabled and the
10249 -- current use clause has not been marked effective.
10251 if Check_Unreferenced
10252 and then Comes_From_Source (Curr)
10253 and then not Is_Effective_Use_Clause (Curr)
10254 and then not In_Instance
10255 and then not In_Inlined_Body
10257 -- We are dealing with a potentially unused use_package_clause
10259 if Nkind (Curr) = N_Use_Package_Clause then
10261 -- Renamings and formal subprograms may cause the associated
10262 -- node to be marked as effective instead of the original.
10264 if not (Present (Associated_Node (N))
10266 (Current_Use_Clause
10267 (Associated_Node (N)))
10268 and then Is_Effective_Use_Clause
10269 (Current_Use_Clause
10270 (Associated_Node (N))))
10272 Error_Msg_Node_1 := Entity (N);
10274 ("use clause for package & has no effect?u?",
10278 -- We are dealing with an unused use_type_clause
10281 Error_Msg_Node_1 := Etype (N);
10283 ("use clause for } has no effect?u?", Curr, Etype (N));
10287 -- Verify that we haven't already processed a redundant
10288 -- use_type_clause within the same scope before we move the
10289 -- current use clause up to a previous one for type T.
10291 if Present (Prev_Use_Clause (Curr)) then
10292 Set_Current_Use_Clause (Entity (N), Prev_Use_Clause (Curr));
10295 Next_Use_Clause (Curr);
10297 end Update_Chain_In_Scope;
10299 -- Start of processing for Update_Use_Clause_Chain
10302 Update_Chain_In_Scope (Scope_Stack.Last);
10304 -- Deal with use clauses within the context area if the current
10305 -- scope is a compilation unit.
10307 if Is_Compilation_Unit (Current_Scope)
10308 and then Sloc (Scope_Stack.Table
10309 (Scope_Stack.Last - 1).Entity) = Standard_Location
10311 Update_Chain_In_Scope (Scope_Stack.Last - 1);
10313 end Update_Use_Clause_Chain;
10315 ---------------------
10316 -- Use_One_Package --
10317 ---------------------
10319 procedure Use_One_Package
10321 Pack_Name : Entity_Id := Empty;
10322 Force : Boolean := False)
10324 procedure Note_Redundant_Use (Clause : Node_Id);
10325 -- Mark the name in a use clause as redundant if the corresponding
10326 -- entity is already use-visible. Emit a warning if the use clause comes
10327 -- from source and the proper warnings are enabled.
10329 ------------------------
10330 -- Note_Redundant_Use --
10331 ------------------------
10333 procedure Note_Redundant_Use (Clause : Node_Id) is
10334 Decl : constant Node_Id := Parent (Clause);
10335 Pack_Name : constant Entity_Id := Entity (Clause);
10337 Cur_Use : Node_Id := Current_Use_Clause (Pack_Name);
10338 Prev_Use : Node_Id := Empty;
10339 Redundant : Node_Id := Empty;
10340 -- The Use_Clause which is actually redundant. In the simplest case
10341 -- it is Pack itself, but when we compile a body we install its
10342 -- context before that of its spec, in which case it is the
10343 -- use_clause in the spec that will appear to be redundant, and we
10344 -- want the warning to be placed on the body. Similar complications
10345 -- appear when the redundancy is between a child unit and one of its
10349 -- Could be renamed...
10351 if No (Cur_Use) then
10352 Cur_Use := Current_Use_Clause (Renamed_Entity (Pack_Name));
10355 Set_Redundant_Use (Clause, True);
10357 -- Do not check for redundant use if clause is generated, or in an
10358 -- instance, or in a predefined unit to avoid misleading warnings
10359 -- that may occur as part of a rtsfind load.
10361 if not Comes_From_Source (Clause)
10362 or else In_Instance
10363 or else not Warn_On_Redundant_Constructs
10364 or else Is_Predefined_Unit (Current_Sem_Unit)
10369 if not Is_Compilation_Unit (Current_Scope) then
10371 -- If the use_clause is in an inner scope, it is made redundant by
10372 -- some clause in the current context, with one exception: If we
10373 -- are compiling a nested package body, and the use_clause comes
10374 -- from then corresponding spec, the clause is not necessarily
10375 -- fully redundant, so we should not warn. If a warning was
10376 -- warranted, it would have been given when the spec was
10379 if Nkind (Parent (Decl)) = N_Package_Specification then
10381 Package_Spec_Entity : constant Entity_Id :=
10382 Defining_Unit_Name (Parent (Decl));
10384 if In_Package_Body (Package_Spec_Entity) then
10390 Redundant := Clause;
10391 Prev_Use := Cur_Use;
10393 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
10395 Cur_Unit : constant Unit_Number_Type :=
10396 Get_Source_Unit (Cur_Use);
10397 New_Unit : constant Unit_Number_Type :=
10398 Get_Source_Unit (Clause);
10403 if Cur_Unit = New_Unit then
10405 -- Redundant clause in same body
10407 Redundant := Clause;
10408 Prev_Use := Cur_Use;
10410 elsif Cur_Unit = Current_Sem_Unit then
10412 -- If the new clause is not in the current unit it has been
10413 -- analyzed first, and it makes the other one redundant.
10414 -- However, if the new clause appears in a subunit, Cur_Unit
10415 -- is still the parent, and in that case the redundant one
10416 -- is the one appearing in the subunit.
10418 if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then
10419 Redundant := Clause;
10420 Prev_Use := Cur_Use;
10422 -- Most common case: redundant clause in body, original
10423 -- clause in spec. Current scope is spec entity.
10425 elsif Current_Scope = Cunit_Entity (Current_Sem_Unit) then
10426 Redundant := Cur_Use;
10427 Prev_Use := Clause;
10430 -- The new clause may appear in an unrelated unit, when
10431 -- the parents of a generic are being installed prior to
10432 -- instantiation. In this case there must be no warning.
10433 -- We detect this case by checking whether the current
10434 -- top of the stack is related to the current
10437 Scop := Current_Scope;
10438 while Present (Scop)
10439 and then Scop /= Standard_Standard
10441 if Is_Compilation_Unit (Scop)
10442 and then not Is_Child_Unit (Scop)
10446 elsif Scop = Cunit_Entity (Current_Sem_Unit) then
10450 Scop := Scope (Scop);
10453 Redundant := Cur_Use;
10454 Prev_Use := Clause;
10457 elsif New_Unit = Current_Sem_Unit then
10458 Redundant := Clause;
10459 Prev_Use := Cur_Use;
10462 -- Neither is the current unit, so they appear in parent or
10463 -- sibling units. Warning will be emitted elsewhere.
10469 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
10470 and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit))))
10472 -- Use_clause is in child unit of current unit, and the child unit
10473 -- appears in the context of the body of the parent, so it has
10474 -- been installed first, even though it is the redundant one.
10475 -- Depending on their placement in the context, the visible or the
10476 -- private parts of the two units, either might appear as
10477 -- redundant, but the message has to be on the current unit.
10479 if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then
10480 Redundant := Cur_Use;
10481 Prev_Use := Clause;
10483 Redundant := Clause;
10484 Prev_Use := Cur_Use;
10487 -- If the new use clause appears in the private part of a parent
10488 -- unit it may appear to be redundant w.r.t. a use clause in a
10489 -- child unit, but the previous use clause was needed in the
10490 -- visible part of the child, and no warning should be emitted.
10492 if Nkind (Parent (Decl)) = N_Package_Specification
10493 and then List_Containing (Decl) =
10494 Private_Declarations (Parent (Decl))
10497 Par : constant Entity_Id :=
10498 Defining_Entity (Parent (Decl));
10499 Spec : constant Node_Id :=
10500 Specification (Unit (Cunit (Current_Sem_Unit)));
10501 Cur_List : constant List_Id := List_Containing (Cur_Use);
10504 if Is_Compilation_Unit (Par)
10505 and then Par /= Cunit_Entity (Current_Sem_Unit)
10507 if Cur_List = Context_Items (Cunit (Current_Sem_Unit))
10508 or else Cur_List = Visible_Declarations (Spec)
10516 -- Finally, if the current use clause is in the context then the
10517 -- clause is redundant when it is nested within the unit.
10519 elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit
10520 and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit
10521 and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause)
10523 Redundant := Clause;
10524 Prev_Use := Cur_Use;
10527 if Present (Redundant) and then Parent (Redundant) /= Prev_Use then
10529 -- Make sure we are looking at most-descendant use_package_clause
10530 -- by traversing the chain with Find_First_Use and then verifying
10531 -- there is no scope manipulation via Most_Descendant_Use_Clause.
10533 if Nkind (Prev_Use) = N_Use_Package_Clause
10535 (Nkind (Parent (Prev_Use)) /= N_Compilation_Unit
10536 or else Most_Descendant_Use_Clause
10537 (Prev_Use, Find_First_Use (Prev_Use)) /= Prev_Use)
10539 Prev_Use := Find_First_Use (Prev_Use);
10542 Error_Msg_Sloc := Sloc (Prev_Use);
10543 Error_Msg_NE -- CODEFIX
10544 ("& is already use-visible through previous use_clause #?r?",
10545 Redundant, Pack_Name);
10547 end Note_Redundant_Use;
10551 Current_Instance : Entity_Id := Empty;
10555 Private_With_OK : Boolean := False;
10556 Real_P : Entity_Id;
10558 -- Start of processing for Use_One_Package
10561 -- Use_One_Package may have been called recursively to handle an
10562 -- implicit use for a auxiliary system package, so set P accordingly
10563 -- and skip redundancy checks.
10565 if No (Pack_Name) and then Present_System_Aux (N) then
10566 P := System_Aux_Id;
10568 -- Check for redundant use_package_clauses
10571 -- Ignore cases where we are dealing with a non user defined package
10572 -- like Standard_Standard or something other than a valid package.
10574 if not Is_Entity_Name (Pack_Name)
10575 or else No (Entity (Pack_Name))
10576 or else Ekind (Entity (Pack_Name)) /= E_Package
10581 -- When a renaming exists we must check it for redundancy. The
10582 -- original package would have already been seen at this point.
10584 if Present (Renamed_Entity (Entity (Pack_Name))) then
10585 P := Renamed_Entity (Entity (Pack_Name));
10587 P := Entity (Pack_Name);
10590 -- Check for redundant clauses then set the current use clause for
10591 -- P if were are not "forcing" an installation from a scope
10592 -- reinstallation that is done throughout analysis for various
10596 Note_Redundant_Use (Pack_Name);
10599 Set_Current_Use_Clause (P, N);
10604 -- Warn about detected redundant clauses
10607 and then In_Open_Scopes (P)
10608 and then not Is_Hidden_Open_Scope (P)
10610 if Warn_On_Redundant_Constructs and then P = Current_Scope then
10611 Error_Msg_NE -- CODEFIX
10612 ("& is already use-visible within itself?r?",
10619 -- Set P back to the non-renamed package so that visibility of the
10620 -- entities within the package can be properly set below.
10622 P := Entity (Pack_Name);
10626 Set_Current_Use_Clause (P, N);
10628 -- Ada 2005 (AI-50217): Check restriction
10630 if From_Limited_With (P) then
10631 Error_Msg_N ("limited withed package cannot appear in use clause", N);
10634 -- Find enclosing instance, if any
10636 if In_Instance then
10637 Current_Instance := Current_Scope;
10638 while not Is_Generic_Instance (Current_Instance) loop
10639 Current_Instance := Scope (Current_Instance);
10642 if No (Hidden_By_Use_Clause (N)) then
10643 Set_Hidden_By_Use_Clause (N, New_Elmt_List);
10647 -- If unit is a package renaming, indicate that the renamed package is
10648 -- also in use (the flags on both entities must remain consistent, and a
10649 -- subsequent use of either of them should be recognized as redundant).
10651 if Present (Renamed_Entity (P)) then
10652 Set_In_Use (Renamed_Entity (P));
10653 Set_Current_Use_Clause (Renamed_Entity (P), N);
10654 Real_P := Renamed_Entity (P);
10659 -- Ada 2005 (AI-262): Check the use_clause of a private withed package
10660 -- found in the private part of a package specification
10662 if In_Private_Part (Current_Scope)
10663 and then Has_Private_With (P)
10664 and then Is_Child_Unit (Current_Scope)
10665 and then Is_Child_Unit (P)
10666 and then Is_Ancestor_Package (Scope (Current_Scope), P)
10668 Private_With_OK := True;
10671 -- Loop through entities in one package making them potentially
10674 Id := First_Entity (P);
10676 and then (Id /= First_Private_Entity (P)
10677 or else Private_With_OK) -- Ada 2005 (AI-262)
10679 Prev := Current_Entity (Id);
10680 while Present (Prev) loop
10681 if Is_Immediately_Visible (Prev)
10682 and then (not Is_Overloadable (Prev)
10683 or else not Is_Overloadable (Id)
10684 or else Type_Conformant (Id, Prev))
10686 if No (Current_Instance) then
10688 -- Potentially use-visible entity remains hidden
10690 if Warn_On_Hiding then
10691 Warn_On_Hiding_Entity (N, Hidden => Id, Visible => Prev,
10692 On_Use_Clause => True);
10695 goto Next_Usable_Entity;
10697 -- A use clause within an instance hides outer global entities,
10698 -- which are not used to resolve local entities in the
10699 -- instance. Note that the predefined entities in Standard
10700 -- could not have been hidden in the generic by a use clause,
10701 -- and therefore remain visible. Other compilation units whose
10702 -- entities appear in Standard must be hidden in an instance.
10704 -- To determine whether an entity is external to the instance
10705 -- we compare the scope depth of its scope with that of the
10706 -- current instance. However, a generic actual of a subprogram
10707 -- instance is declared in the wrapper package but will not be
10708 -- hidden by a use-visible entity. similarly, an entity that is
10709 -- declared in an enclosing instance will not be hidden by an
10710 -- an entity declared in a generic actual, which can only have
10711 -- been use-visible in the generic and will not have hidden the
10712 -- entity in the generic parent.
10714 -- If Id is called Standard, the predefined package with the
10715 -- same name is in the homonym chain. It has to be ignored
10716 -- because it has no defined scope (being the only entity in
10717 -- the system with this mandated behavior).
10719 elsif not Is_Hidden (Id)
10720 and then Present (Scope (Prev))
10721 and then not Is_Wrapper_Package (Scope (Prev))
10722 and then Scope_Depth (Scope (Prev)) <
10723 Scope_Depth (Current_Instance)
10724 and then (Scope (Prev) /= Standard_Standard
10725 or else Sloc (Prev) > Standard_Location)
10727 if In_Open_Scopes (Scope (Prev))
10728 and then Is_Generic_Instance (Scope (Prev))
10729 and then Present (Associated_Formal_Package (P))
10734 Set_Is_Potentially_Use_Visible (Id);
10735 Set_Is_Immediately_Visible (Prev, False);
10736 Append_Elmt (Prev, Hidden_By_Use_Clause (N));
10740 -- A user-defined operator is not use-visible if the predefined
10741 -- operator for the type is immediately visible, which is the case
10742 -- if the type of the operand is in an open scope. This does not
10743 -- apply to user-defined operators that have operands of different
10744 -- types, because the predefined mixed mode operations (multiply
10745 -- and divide) apply to universal types and do not hide anything.
10747 elsif Ekind (Prev) = E_Operator
10748 and then Operator_Matches_Spec (Prev, Id)
10749 and then In_Open_Scopes
10750 (Scope (Base_Type (Etype (First_Formal (Id)))))
10751 and then (No (Next_Formal (First_Formal (Id)))
10752 or else Etype (First_Formal (Id)) =
10753 Etype (Next_Formal (First_Formal (Id)))
10754 or else Chars (Prev) = Name_Op_Expon)
10756 goto Next_Usable_Entity;
10758 -- In an instance, two homonyms may become use_visible through the
10759 -- actuals of distinct formal packages. In the generic, only the
10760 -- current one would have been visible, so make the other one
10761 -- not use_visible.
10763 -- In certain pathological cases it is possible that unrelated
10764 -- homonyms from distinct formal packages may exist in an
10765 -- uninstalled scope. We must test for that here.
10767 elsif Present (Current_Instance)
10768 and then Is_Potentially_Use_Visible (Prev)
10769 and then not Is_Overloadable (Prev)
10770 and then Scope (Id) /= Scope (Prev)
10771 and then Used_As_Generic_Actual (Scope (Prev))
10772 and then Used_As_Generic_Actual (Scope (Id))
10773 and then Is_List_Member (Scope (Prev))
10774 and then not In_Same_List (Current_Use_Clause (Scope (Prev)),
10775 Current_Use_Clause (Scope (Id)))
10777 Set_Is_Potentially_Use_Visible (Prev, False);
10778 Append_Elmt (Prev, Hidden_By_Use_Clause (N));
10781 Prev := Homonym (Prev);
10784 -- On exit, we know entity is not hidden, unless it is private
10786 if not Is_Hidden (Id)
10787 and then (not Is_Child_Unit (Id) or else Is_Visible_Lib_Unit (Id))
10789 Set_Is_Potentially_Use_Visible (Id);
10791 if Is_Private_Type (Id) and then Present (Full_View (Id)) then
10792 Set_Is_Potentially_Use_Visible (Full_View (Id));
10796 <<Next_Usable_Entity>>
10800 -- Child units are also made use-visible by a use clause, but they may
10801 -- appear after all visible declarations in the parent entity list.
10803 while Present (Id) loop
10804 if Is_Child_Unit (Id) and then Is_Visible_Lib_Unit (Id) then
10805 Set_Is_Potentially_Use_Visible (Id);
10811 if Chars (Real_P) = Name_System
10812 and then Scope (Real_P) = Standard_Standard
10813 and then Present_System_Aux (N)
10815 Use_One_Package (N);
10817 end Use_One_Package;
10823 procedure Use_One_Type
10825 Installed : Boolean := False;
10826 Force : Boolean := False)
10828 function Spec_Reloaded_For_Body return Boolean;
10829 -- Determine whether the compilation unit is a package body and the use
10830 -- type clause is in the spec of the same package. Even though the spec
10831 -- was analyzed first, its context is reloaded when analysing the body.
10833 procedure Use_Class_Wide_Operations (Typ : Entity_Id);
10834 -- AI05-150: if the use_type_clause carries the "all" qualifier,
10835 -- class-wide operations of ancestor types are use-visible if the
10836 -- ancestor type is visible.
10838 ----------------------------
10839 -- Spec_Reloaded_For_Body --
10840 ----------------------------
10842 function Spec_Reloaded_For_Body return Boolean is
10844 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
10846 Spec : constant Node_Id :=
10847 Parent (List_Containing (Parent (Id)));
10850 -- Check whether type is declared in a package specification,
10851 -- and current unit is the corresponding package body. The
10852 -- use clauses themselves may be within a nested package.
10855 Nkind (Spec) = N_Package_Specification
10856 and then In_Same_Source_Unit
10857 (Corresponding_Body (Parent (Spec)),
10858 Cunit_Entity (Current_Sem_Unit));
10863 end Spec_Reloaded_For_Body;
10865 -------------------------------
10866 -- Use_Class_Wide_Operations --
10867 -------------------------------
10869 procedure Use_Class_Wide_Operations (Typ : Entity_Id) is
10870 function Is_Class_Wide_Operation_Of
10872 T : Entity_Id) return Boolean;
10873 -- Determine whether a subprogram has a class-wide parameter or
10874 -- result that is T'Class.
10876 ---------------------------------
10877 -- Is_Class_Wide_Operation_Of --
10878 ---------------------------------
10880 function Is_Class_Wide_Operation_Of
10882 T : Entity_Id) return Boolean
10884 Formal : Entity_Id;
10887 Formal := First_Formal (Op);
10888 while Present (Formal) loop
10889 if Etype (Formal) = Class_Wide_Type (T) then
10893 Next_Formal (Formal);
10896 if Etype (Op) = Class_Wide_Type (T) then
10901 end Is_Class_Wide_Operation_Of;
10908 -- Start of processing for Use_Class_Wide_Operations
10911 Scop := Scope (Typ);
10912 if not Is_Hidden (Scop) then
10913 Ent := First_Entity (Scop);
10914 while Present (Ent) loop
10915 if Is_Overloadable (Ent)
10916 and then Is_Class_Wide_Operation_Of (Ent, Typ)
10917 and then not Is_Potentially_Use_Visible (Ent)
10919 Set_Is_Potentially_Use_Visible (Ent);
10920 Append_Elmt (Ent, Used_Operations (Parent (Id)));
10927 if Is_Derived_Type (Typ) then
10928 Use_Class_Wide_Operations (Etype (Base_Type (Typ)));
10930 end Use_Class_Wide_Operations;
10935 Is_Known_Used : Boolean;
10936 Op_List : Elist_Id;
10939 -- Start of processing for Use_One_Type
10942 if Entity (Id) = Any_Type then
10946 -- It is the type determined by the subtype mark (8.4(8)) whose
10947 -- operations become potentially use-visible.
10949 T := Base_Type (Entity (Id));
10951 -- Either the type itself is used, the package where it is declared is
10952 -- in use or the entity is declared in the current package, thus
10957 and then ((Present (Current_Use_Clause (T))
10958 and then All_Present (Current_Use_Clause (T)))
10959 or else not All_Present (Parent (Id))))
10960 or else In_Use (Scope (T))
10961 or else Scope (T) = Current_Scope;
10963 Set_Redundant_Use (Id,
10964 Is_Known_Used or else Is_Potentially_Use_Visible (T));
10966 if Ekind (T) = E_Incomplete_Type then
10967 Error_Msg_N ("premature usage of incomplete type", Id);
10969 elsif In_Open_Scopes (Scope (T)) then
10972 -- A limited view cannot appear in a use_type_clause. However, an access
10973 -- type whose designated type is limited has the flag but is not itself
10974 -- a limited view unless we only have a limited view of its enclosing
10977 elsif From_Limited_With (T) and then From_Limited_With (Scope (T)) then
10979 ("incomplete type from limited view cannot appear in use clause",
10982 -- If the use clause is redundant, Used_Operations will usually be
10983 -- empty, but we need to set it to empty here in one case: If we are
10984 -- instantiating a generic library unit, then we install the ancestors
10985 -- of that unit in the scope stack, which involves reprocessing use
10986 -- clauses in those ancestors. Such a use clause will typically have a
10987 -- nonempty Used_Operations unless it was redundant in the generic unit,
10988 -- even if it is redundant at the place of the instantiation.
10990 elsif Redundant_Use (Id) then
10991 Set_Used_Operations (Parent (Id), New_Elmt_List);
10993 -- If the subtype mark designates a subtype in a different package,
10994 -- we have to check that the parent type is visible, otherwise the
10995 -- use_type_clause is a no-op. Not clear how to do that???
10998 Set_Current_Use_Clause (T, Parent (Id));
11001 -- If T is tagged, primitive operators on class-wide operands are
11002 -- also deemed available. Note that this is really necessary only
11003 -- in semantics-only mode, because the primitive operators are not
11004 -- fully constructed in this mode, but we do it in all modes for the
11005 -- sake of uniformity, as this should not matter in practice.
11007 if Is_Tagged_Type (T) then
11008 Set_In_Use (Class_Wide_Type (T));
11011 -- Iterate over primitive operations of the type. If an operation is
11012 -- already use_visible, it is the result of a previous use_clause,
11013 -- and already appears on the corresponding entity chain. If the
11014 -- clause is being reinstalled, operations are already use-visible.
11020 Op_List := Collect_Primitive_Operations (T);
11021 Elmt := First_Elmt (Op_List);
11022 while Present (Elmt) loop
11023 if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol
11024 or else Chars (Node (Elmt)) in Any_Operator_Name)
11025 and then not Is_Hidden (Node (Elmt))
11026 and then not Is_Potentially_Use_Visible (Node (Elmt))
11028 Set_Is_Potentially_Use_Visible (Node (Elmt));
11029 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id)));
11031 elsif Ada_Version >= Ada_2012
11032 and then All_Present (Parent (Id))
11033 and then not Is_Hidden (Node (Elmt))
11034 and then not Is_Potentially_Use_Visible (Node (Elmt))
11036 Set_Is_Potentially_Use_Visible (Node (Elmt));
11037 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id)));
11044 if Ada_Version >= Ada_2012
11045 and then All_Present (Parent (Id))
11046 and then Is_Tagged_Type (T)
11048 Use_Class_Wide_Operations (T);
11052 -- If warning on redundant constructs, check for unnecessary WITH
11055 and then Warn_On_Redundant_Constructs
11056 and then Is_Known_Used
11058 -- with P; with P; use P;
11059 -- package P is package X is package body X is
11060 -- type T ... use P.T;
11062 -- The compilation unit is the body of X. GNAT first compiles the
11063 -- spec of X, then proceeds to the body. At that point P is marked
11064 -- as use visible. The analysis then reinstalls the spec along with
11065 -- its context. The use clause P.T is now recognized as redundant,
11066 -- but in the wrong context. Do not emit a warning in such cases.
11067 -- Do not emit a warning either if we are in an instance, there is
11068 -- no redundancy between an outer use_clause and one that appears
11069 -- within the generic.
11071 and then not Spec_Reloaded_For_Body
11072 and then not In_Instance
11073 and then not In_Inlined_Body
11075 -- The type already has a use clause
11079 -- Case where we know the current use clause for the type
11081 if Present (Current_Use_Clause (T)) then
11082 Use_Clause_Known : declare
11083 Clause1 : constant Node_Id :=
11084 Find_First_Use (Current_Use_Clause (T));
11085 Clause2 : constant Node_Id := Parent (Id);
11092 -- Start of processing for Use_Clause_Known
11095 -- If the unit is a subprogram body that acts as spec, the
11096 -- context clause is shared with the constructed subprogram
11097 -- spec. Clearly there is no redundancy.
11099 if Clause1 = Clause2 then
11103 Unit1 := Unit (Enclosing_Comp_Unit_Node (Clause1));
11104 Unit2 := Unit (Enclosing_Comp_Unit_Node (Clause2));
11106 -- If both clauses are on same unit, or one is the body of
11107 -- the other, or one of them is in a subunit, report
11108 -- redundancy on the later one.
11111 or else Nkind (Unit1) = N_Subunit
11113 (Nkind (Unit2) in N_Package_Body | N_Subprogram_Body
11114 and then Nkind (Unit1) /= Nkind (Unit2)
11115 and then Nkind (Unit1) /= N_Subunit)
11117 Error_Msg_Sloc := Sloc (Clause1);
11118 Error_Msg_NE -- CODEFIX
11119 ("& is already use-visible through previous "
11120 & "use_type_clause #?r?", Clause2, T);
11124 -- If there is a redundant use_type_clause in a child unit
11125 -- determine which of the units is more deeply nested. If a
11126 -- unit is a package instance, retrieve the entity and its
11127 -- scope from the instance spec.
11129 Ent1 := Entity_Of_Unit (Unit1);
11130 Ent2 := Entity_Of_Unit (Unit2);
11132 -- When the scope of both units' entities are
11133 -- Standard_Standard then neither Unit1 or Unit2 are child
11134 -- units - so return in that case.
11136 if Scope
(Ent1
) = Standard_Standard
11137 and then Scope
(Ent2
) = Standard_Standard
11141 -- Otherwise, determine if one of the units is not a child
11143 elsif Scope
(Ent2
) = Standard_Standard
then
11144 Error_Msg_Sloc
:= Sloc
(Clause2
);
11147 elsif Scope
(Ent1
) = Standard_Standard
then
11148 Error_Msg_Sloc
:= Sloc
(Id
);
11151 -- If both units are child units, we determine which one is
11152 -- the descendant by the scope distance to the ultimate
11161 S1
:= Scope
(Ent1
);
11162 S2
:= Scope
(Ent2
);
11164 and then Present
(S2
)
11165 and then S1
/= Standard_Standard
11166 and then S2
/= Standard_Standard
11172 if S1
= Standard_Standard
then
11173 Error_Msg_Sloc
:= Sloc
(Id
);
11176 Error_Msg_Sloc
:= Sloc
(Clause2
);
11182 if Parent
(Id
) /= Err_No
then
11183 if Most_Descendant_Use_Clause
11184 (Err_No
, Parent
(Id
)) = Parent
(Id
)
11186 Error_Msg_Sloc
:= Sloc
(Err_No
);
11187 Err_No
:= Parent
(Id
);
11190 Error_Msg_NE
-- CODEFIX
11191 ("& is already use-visible through previous "
11192 & "use_type_clause #?r?", Err_No
, Id
);
11194 end Use_Clause_Known
;
11196 -- Here Current_Use_Clause is not set for T, so we do not have the
11197 -- location information available.
11200 Error_Msg_NE
-- CODEFIX
11201 ("& is already use-visible through previous "
11202 & "use_type_clause?r?", Id
, T
);
11205 -- The package where T is declared is already used
11207 elsif In_Use
(Scope
(T
)) then
11208 -- Due to expansion of contracts we could be attempting to issue
11209 -- a spurious warning - so verify there is a previous use clause.
11211 if Current_Use_Clause
(Scope
(T
)) /=
11212 Find_First_Use
(Current_Use_Clause
(Scope
(T
)))
11215 Sloc
(Find_First_Use
(Current_Use_Clause
(Scope
(T
))));
11216 Error_Msg_NE
-- CODEFIX
11217 ("& is already use-visible through package use clause #?r?",
11221 -- The current scope is the package where T is declared
11224 Error_Msg_Node_2
:= Scope
(T
);
11225 Error_Msg_NE
-- CODEFIX
11226 ("& is already use-visible inside package &?r?", Id
, T
);
11235 procedure Write_Info
is
11236 Id
: Entity_Id
:= First_Entity
(Current_Scope
);
11239 -- No point in dumping standard entities
11241 if Current_Scope
= Standard_Standard
then
11245 Write_Str
("========================================================");
11247 Write_Str
(" Defined Entities in ");
11248 Write_Name
(Chars
(Current_Scope
));
11250 Write_Str
("========================================================");
11254 Write_Str
("-- none --");
11258 while Present
(Id
) loop
11259 Write_Entity_Info
(Id
, " ");
11264 if Scope
(Current_Scope
) = Standard_Standard
then
11266 -- Print information on the current unit itself
11268 Write_Entity_Info
(Current_Scope
, " ");
11281 for J
in reverse 1 .. Scope_Stack
.Last
loop
11282 S
:= Scope_Stack
.Table
(J
).Entity
;
11283 Write_Int
(Int
(S
));
11284 Write_Str
(" === ");
11285 Write_Name
(Chars
(S
));
11294 procedure we
(S
: Entity_Id
) is
11297 E
:= First_Entity
(S
);
11298 while Present
(E
) loop
11299 Write_Int
(Int
(E
));
11300 Write_Str
(" === ");
11301 Write_Name
(Chars
(E
));