1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Exp_Tss
; use Exp_Tss
;
32 with Exp_Util
; use Exp_Util
;
33 with Fname
; use Fname
;
34 with Freeze
; use Freeze
;
35 with Impunit
; use Impunit
;
37 with Lib
.Load
; use Lib
.Load
;
38 with Lib
.Xref
; use Lib
.Xref
;
39 with Namet
; use Namet
;
40 with Namet
.Sp
; use Namet
.Sp
;
41 with Nlists
; use Nlists
;
42 with Nmake
; use Nmake
;
44 with Output
; use Output
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Cat
; use Sem_Cat
;
50 with Sem_Ch3
; use Sem_Ch3
;
51 with Sem_Ch4
; use Sem_Ch4
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch12
; use Sem_Ch12
;
54 with Sem_Disp
; use Sem_Disp
;
55 with Sem_Dist
; use Sem_Dist
;
56 with Sem_Res
; use Sem_Res
;
57 with Sem_Util
; use Sem_Util
;
58 with Sem_Type
; use Sem_Type
;
59 with Stand
; use Stand
;
60 with Sinfo
; use Sinfo
;
61 with Sinfo
.CN
; use Sinfo
.CN
;
62 with Snames
; use Snames
;
63 with Style
; use Style
;
65 with Tbuild
; use Tbuild
;
66 with Uintp
; use Uintp
;
68 package body Sem_Ch8
is
70 ------------------------------------
71 -- Visibility and Name Resolution --
72 ------------------------------------
74 -- This package handles name resolution and the collection of
75 -- interpretations for overloaded names, prior to overload resolution.
77 -- Name resolution is the process that establishes a mapping between source
78 -- identifiers and the entities they denote at each point in the program.
79 -- Each entity is represented by a defining occurrence. Each identifier
80 -- that denotes an entity points to the corresponding defining occurrence.
81 -- This is the entity of the applied occurrence. Each occurrence holds
82 -- an index into the names table, where source identifiers are stored.
84 -- Each entry in the names table for an identifier or designator uses the
85 -- Info pointer to hold a link to the currently visible entity that has
86 -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id
87 -- in package Sem_Util). The visibility is initialized at the beginning of
88 -- semantic processing to make entities in package Standard immediately
89 -- visible. The visibility table is used in a more subtle way when
90 -- compiling subunits (see below).
92 -- Entities that have the same name (i.e. homonyms) are chained. In the
93 -- case of overloaded entities, this chain holds all the possible meanings
94 -- of a given identifier. The process of overload resolution uses type
95 -- information to select from this chain the unique meaning of a given
98 -- Entities are also chained in their scope, through the Next_Entity link.
99 -- As a consequence, the name space is organized as a sparse matrix, where
100 -- each row corresponds to a scope, and each column to a source identifier.
101 -- Open scopes, that is to say scopes currently being compiled, have their
102 -- corresponding rows of entities in order, innermost scope first.
104 -- The scopes of packages that are mentioned in context clauses appear in
105 -- no particular order, interspersed among open scopes. This is because
106 -- in the course of analyzing the context of a compilation, a package
107 -- declaration is first an open scope, and subsequently an element of the
108 -- context. If subunits or child units are present, a parent unit may
109 -- appear under various guises at various times in the compilation.
111 -- When the compilation of the innermost scope is complete, the entities
112 -- defined therein are no longer visible. If the scope is not a package
113 -- declaration, these entities are never visible subsequently, and can be
114 -- removed from visibility chains. If the scope is a package declaration,
115 -- its visible declarations may still be accessible. Therefore the entities
116 -- defined in such a scope are left on the visibility chains, and only
117 -- their visibility (immediately visibility or potential use-visibility)
120 -- The ordering of homonyms on their chain does not necessarily follow
121 -- the order of their corresponding scopes on the scope stack. For
122 -- example, if package P and the enclosing scope both contain entities
123 -- named E, then when compiling the package body the chain for E will
124 -- hold the global entity first, and the local one (corresponding to
125 -- the current inner scope) next. As a result, name resolution routines
126 -- do not assume any relative ordering of the homonym chains, either
127 -- for scope nesting or to order of appearance of context clauses.
129 -- When compiling a child unit, entities in the parent scope are always
130 -- immediately visible. When compiling the body of a child unit, private
131 -- entities in the parent must also be made immediately visible. There
132 -- are separate routines to make the visible and private declarations
133 -- visible at various times (see package Sem_Ch7).
135 -- +--------+ +-----+
136 -- | In use |-------->| EU1 |-------------------------->
137 -- +--------+ +-----+
139 -- +--------+ +-----+ +-----+
140 -- | Stand. |---------------->| ES1 |--------------->| ES2 |--->
141 -- +--------+ +-----+ +-----+
143 -- +---------+ | +-----+
144 -- | with'ed |------------------------------>| EW2 |--->
145 -- +---------+ | +-----+
147 -- +--------+ +-----+ +-----+
148 -- | Scope2 |---------------->| E12 |--------------->| E22 |--->
149 -- +--------+ +-----+ +-----+
151 -- +--------+ +-----+ +-----+
152 -- | Scope1 |---------------->| E11 |--------------->| E12 |--->
153 -- +--------+ +-----+ +-----+
157 -- | | with'ed |----------------------------------------->
161 -- (innermost first) | |
162 -- +----------------------------+
163 -- Names table => | Id1 | | | | Id2 |
164 -- +----------------------------+
166 -- Name resolution must deal with several syntactic forms: simple names,
167 -- qualified names, indexed names, and various forms of calls.
169 -- Each identifier points to an entry in the names table. The resolution
170 -- of a simple name consists in traversing the homonym chain, starting
171 -- from the names table. If an entry is immediately visible, it is the one
172 -- designated by the identifier. If only potentially use-visible entities
173 -- are on the chain, we must verify that they do not hide each other. If
174 -- the entity we find is overloadable, we collect all other overloadable
175 -- entities on the chain as long as they are not hidden.
177 -- To resolve expanded names, we must find the entity at the intersection
178 -- of the entity chain for the scope (the prefix) and the homonym chain
179 -- for the selector. In general, homonym chains will be much shorter than
180 -- entity chains, so it is preferable to start from the names table as
181 -- well. If the entity found is overloadable, we must collect all other
182 -- interpretations that are defined in the scope denoted by the prefix.
184 -- For records, protected types, and tasks, their local entities are
185 -- removed from visibility chains on exit from the corresponding scope.
186 -- From the outside, these entities are always accessed by selected
187 -- notation, and the entity chain for the record type, protected type,
188 -- etc. is traversed sequentially in order to find the designated entity.
190 -- The discriminants of a type and the operations of a protected type or
191 -- task are unchained on exit from the first view of the type, (such as
192 -- a private or incomplete type declaration, or a protected type speci-
193 -- fication) and re-chained when compiling the second view.
195 -- In the case of operators, we do not make operators on derived types
196 -- explicit. As a result, the notation P."+" may denote either a user-
197 -- defined function with name "+", or else an implicit declaration of the
198 -- operator "+" in package P. The resolution of expanded names always
199 -- tries to resolve an operator name as such an implicitly defined entity,
200 -- in addition to looking for explicit declarations.
202 -- All forms of names that denote entities (simple names, expanded names,
203 -- character literals in some cases) have a Entity attribute, which
204 -- identifies the entity denoted by the name.
206 ---------------------
207 -- The Scope Stack --
208 ---------------------
210 -- The Scope stack keeps track of the scopes currently been compiled.
211 -- Every entity that contains declarations (including records) is placed
212 -- on the scope stack while it is being processed, and removed at the end.
213 -- Whenever a non-package scope is exited, the entities defined therein
214 -- are removed from the visibility table, so that entities in outer scopes
215 -- become visible (see previous description). On entry to Sem, the scope
216 -- stack only contains the package Standard. As usual, subunits complicate
217 -- this picture ever so slightly.
219 -- The Rtsfind mechanism can force a call to Semantics while another
220 -- compilation is in progress. The unit retrieved by Rtsfind must be
221 -- compiled in its own context, and has no access to the visibility of
222 -- the unit currently being compiled. The procedures Save_Scope_Stack and
223 -- Restore_Scope_Stack make entities in current open scopes invisible
224 -- before compiling the retrieved unit, and restore the compilation
225 -- environment afterwards.
227 ------------------------
228 -- Compiling subunits --
229 ------------------------
231 -- Subunits must be compiled in the environment of the corresponding stub,
232 -- that is to say with the same visibility into the parent (and its
233 -- context) that is available at the point of the stub declaration, but
234 -- with the additional visibility provided by the context clause of the
235 -- subunit itself. As a result, compilation of a subunit forces compilation
236 -- of the parent (see description in lib-). At the point of the stub
237 -- declaration, Analyze is called recursively to compile the proper body of
238 -- the subunit, but without reinitializing the names table, nor the scope
239 -- stack (i.e. standard is not pushed on the stack). In this fashion the
240 -- context of the subunit is added to the context of the parent, and the
241 -- subunit is compiled in the correct environment. Note that in the course
242 -- of processing the context of a subunit, Standard will appear twice on
243 -- the scope stack: once for the parent of the subunit, and once for the
244 -- unit in the context clause being compiled. However, the two sets of
245 -- entities are not linked by homonym chains, so that the compilation of
246 -- any context unit happens in a fresh visibility environment.
248 -------------------------------
249 -- Processing of USE Clauses --
250 -------------------------------
252 -- Every defining occurrence has a flag indicating if it is potentially use
253 -- visible. Resolution of simple names examines this flag. The processing
254 -- of use clauses consists in setting this flag on all visible entities
255 -- defined in the corresponding package. On exit from the scope of the use
256 -- clause, the corresponding flag must be reset. However, a package may
257 -- appear in several nested use clauses (pathological but legal, alas!)
258 -- which forces us to use a slightly more involved scheme:
260 -- a) The defining occurrence for a package holds a flag -In_Use- to
261 -- indicate that it is currently in the scope of a use clause. If a
262 -- redundant use clause is encountered, then the corresponding occurrence
263 -- of the package name is flagged -Redundant_Use-.
265 -- b) On exit from a scope, the use clauses in its declarative part are
266 -- scanned. The visibility flag is reset in all entities declared in
267 -- package named in a use clause, as long as the package is not flagged
268 -- as being in a redundant use clause (in which case the outer use
269 -- clause is still in effect, and the direct visibility of its entities
270 -- must be retained).
272 -- Note that entities are not removed from their homonym chains on exit
273 -- from the package specification. A subsequent use clause does not need
274 -- to rechain the visible entities, but only to establish their direct
277 -----------------------------------
278 -- Handling private declarations --
279 -----------------------------------
281 -- The principle that each entity has a single defining occurrence clashes
282 -- with the presence of two separate definitions for private types: the
283 -- first is the private type declaration, and second is the full type
284 -- declaration. It is important that all references to the type point to
285 -- the same defining occurrence, namely the first one. To enforce the two
286 -- separate views of the entity, the corresponding information is swapped
287 -- between the two declarations. Outside of the package, the defining
288 -- occurrence only contains the private declaration information, while in
289 -- the private part and the body of the package the defining occurrence
290 -- contains the full declaration. To simplify the swap, the defining
291 -- occurrence that currently holds the private declaration points to the
292 -- full declaration. During semantic processing the defining occurrence
293 -- also points to a list of private dependents, that is to say access types
294 -- or composite types whose designated types or component types are
295 -- subtypes or derived types of the private type in question. After the
296 -- full declaration has been seen, the private dependents are updated to
297 -- indicate that they have full definitions.
299 ------------------------------------
300 -- Handling of Undefined Messages --
301 ------------------------------------
303 -- In normal mode, only the first use of an undefined identifier generates
304 -- a message. The table Urefs is used to record error messages that have
305 -- been issued so that second and subsequent ones do not generate further
306 -- messages. However, the second reference causes text to be added to the
307 -- original undefined message noting "(more references follow)". The
308 -- full error list option (-gnatf) forces messages to be generated for
309 -- every reference and disconnects the use of this table.
311 type Uref_Entry
is record
313 -- Node for identifier for which original message was posted. The
314 -- Chars field of this identifier is used to detect later references
315 -- to the same identifier.
318 -- Records error message Id of original undefined message. Reset to
319 -- No_Error_Msg after the second occurrence, where it is used to add
320 -- text to the original message as described above.
323 -- Set if the message is not visible rather than undefined
326 -- Records location of error message. Used to make sure that we do
327 -- not consider a, b : undefined as two separate instances, which
328 -- would otherwise happen, since the parser converts this sequence
329 -- to a : undefined; b : undefined.
333 package Urefs
is new Table
.Table
(
334 Table_Component_Type
=> Uref_Entry
,
335 Table_Index_Type
=> Nat
,
336 Table_Low_Bound
=> 1,
338 Table_Increment
=> 100,
339 Table_Name
=> "Urefs");
341 Candidate_Renaming
: Entity_Id
;
342 -- Holds a candidate interpretation that appears in a subprogram renaming
343 -- declaration and does not match the given specification, but matches at
344 -- least on the first formal. Allows better error message when given
345 -- specification omits defaulted parameters, a common error.
347 -----------------------
348 -- Local Subprograms --
349 -----------------------
351 procedure Analyze_Generic_Renaming
354 -- Common processing for all three kinds of generic renaming declarations.
355 -- Enter new name and indicate that it renames the generic unit.
357 procedure Analyze_Renamed_Character
361 -- Renamed entity is given by a character literal, which must belong
362 -- to the return type of the new entity. Is_Body indicates whether the
363 -- declaration is a renaming_as_body. If the original declaration has
364 -- already been frozen (because of an intervening body, e.g.) the body of
365 -- the function must be built now. The same applies to the following
366 -- various renaming procedures.
368 procedure Analyze_Renamed_Dereference
372 -- Renamed entity is given by an explicit dereference. Prefix must be a
373 -- conformant access_to_subprogram type.
375 procedure Analyze_Renamed_Entry
379 -- If the renamed entity in a subprogram renaming is an entry or protected
380 -- subprogram, build a body for the new entity whose only statement is a
381 -- call to the renamed entity.
383 procedure Analyze_Renamed_Family_Member
387 -- Used when the renamed entity is an indexed component. The prefix must
388 -- denote an entry family.
390 procedure Analyze_Renamed_Primitive_Operation
394 -- If the renamed entity in a subprogram renaming is a primitive operation
395 -- or a class-wide operation in prefix form, save the target object, which
396 -- must be added to the list of actuals in any subsequent call.
398 function Applicable_Use
(Pack_Name
: Node_Id
) return Boolean;
399 -- Common code to Use_One_Package and Set_Use, to determine whether
400 -- use clause must be processed. Pack_Name is an entity name that
401 -- references the package in question.
403 procedure Attribute_Renaming
(N
: Node_Id
);
404 -- Analyze renaming of attribute as function. The renaming declaration N
405 -- is rewritten as a function body that returns the attribute reference
406 -- applied to the formals of the function.
408 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
);
409 -- A renaming_as_body may occur after the entity of the original decla-
410 -- ration has been frozen. In that case, the body of the new entity must
411 -- be built now, because the usual mechanism of building the renamed
412 -- body at the point of freezing will not work. Subp is the subprogram
413 -- for which N provides the Renaming_As_Body.
415 procedure Check_In_Previous_With_Clause
418 -- N is a use_package clause and Nam the package name, or N is a use_type
419 -- clause and Nam is the prefix of the type name. In either case, verify
420 -- that the package is visible at that point in the context: either it
421 -- appears in a previous with_clause, or because it is a fully qualified
422 -- name and the root ancestor appears in a previous with_clause.
424 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
);
425 -- Verify that the entity in a renaming declaration that is a library unit
426 -- is itself a library unit and not a nested unit or subunit. Also check
427 -- that if the renaming is a child unit of a generic parent, then the
428 -- renamed unit must also be a child unit of that parent. Finally, verify
429 -- that a renamed generic unit is not an implicit child declared within
430 -- an instance of the parent.
432 procedure Chain_Use_Clause
(N
: Node_Id
);
433 -- Chain use clause onto list of uses clauses headed by First_Use_Clause in
434 -- the proper scope table entry. This is usually the current scope, but it
435 -- will be an inner scope when installing the use clauses of the private
436 -- declarations of a parent unit prior to compiling the private part of a
437 -- child unit. This chain is traversed when installing/removing use clauses
438 -- when compiling a subunit or instantiating a generic body on the fly,
439 -- when it is necessary to save and restore full environments.
441 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean;
442 -- Find a type derived from Character or Wide_Character in the prefix of N.
443 -- Used to resolved qualified names whose selector is a character literal.
445 function Has_Private_With
(E
: Entity_Id
) return Boolean;
446 -- Ada 2005 (AI-262): Determines if the current compilation unit has a
447 -- private with on E.
449 procedure Find_Expanded_Name
(N
: Node_Id
);
450 -- Selected component is known to be expanded name. Verify legality
451 -- of selector given the scope denoted by prefix.
453 function Find_Renamed_Entity
457 Is_Actual
: Boolean := False) return Entity_Id
;
458 -- Find the renamed entity that corresponds to the given parameter profile
459 -- in a subprogram renaming declaration. The renamed entity may be an
460 -- operator, a subprogram, an entry, or a protected operation. Is_Actual
461 -- indicates that the renaming is the one generated for an actual subpro-
462 -- gram in an instance, for which special visibility checks apply.
464 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean;
465 -- N is an expanded name whose selector is an operator name (eg P."+").
466 -- declarative part contains an implicit declaration of an operator if it
467 -- has a declaration of a type to which one of the predefined operators
468 -- apply. The existence of this routine is an implementation artifact. A
469 -- more straightforward but more space-consuming choice would be to make
470 -- all inherited operators explicit in the symbol table.
472 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
);
473 -- A subprogram defined by a renaming declaration inherits the parameter
474 -- profile of the renamed entity. The subtypes given in the subprogram
475 -- specification are discarded and replaced with those of the renamed
476 -- subprogram, which are then used to recheck the default values.
478 function Is_Appropriate_For_Record
(T
: Entity_Id
) return Boolean;
479 -- Prefix is appropriate for record if it is of a record type, or an access
482 function Is_Appropriate_For_Entry_Prefix
(T
: Entity_Id
) return Boolean;
483 -- True if it is of a task type, a protected type, or else an access to one
486 procedure Note_Redundant_Use
(Clause
: Node_Id
);
487 -- Mark the name in a use clause as redundant if the corresponding entity
488 -- is already use-visible. Emit a warning if the use clause comes from
489 -- source and the proper warnings are enabled.
491 procedure Premature_Usage
(N
: Node_Id
);
492 -- Diagnose usage of an entity before it is visible
494 procedure Use_One_Package
(P
: Entity_Id
; N
: Node_Id
);
495 -- Make visible entities declared in package P potentially use-visible
496 -- in the current context. Also used in the analysis of subunits, when
497 -- re-installing use clauses of parent units. N is the use_clause that
498 -- names P (and possibly other packages).
500 procedure Use_One_Type
(Id
: Node_Id
);
501 -- Id is the subtype mark from a use type clause. This procedure makes
502 -- the primitive operators of the type potentially use-visible.
504 procedure Write_Info
;
505 -- Write debugging information on entities declared in current scope
507 procedure Write_Scopes
;
508 pragma Warnings
(Off
, Write_Scopes
);
509 -- Debugging information: dump all entities on scope stack
511 --------------------------------
512 -- Analyze_Exception_Renaming --
513 --------------------------------
515 -- The language only allows a single identifier, but the tree holds an
516 -- identifier list. The parser has already issued an error message if
517 -- there is more than one element in the list.
519 procedure Analyze_Exception_Renaming
(N
: Node_Id
) is
520 Id
: constant Node_Id
:= Defining_Identifier
(N
);
521 Nam
: constant Node_Id
:= Name
(N
);
527 Set_Ekind
(Id
, E_Exception
);
528 Set_Exception_Code
(Id
, Uint_0
);
529 Set_Etype
(Id
, Standard_Exception_Type
);
530 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
532 if not Is_Entity_Name
(Nam
) or else
533 Ekind
(Entity
(Nam
)) /= E_Exception
535 Error_Msg_N
("invalid exception name in renaming", Nam
);
537 if Present
(Renamed_Object
(Entity
(Nam
))) then
538 Set_Renamed_Object
(Id
, Renamed_Object
(Entity
(Nam
)));
540 Set_Renamed_Object
(Id
, Entity
(Nam
));
543 end Analyze_Exception_Renaming
;
545 ---------------------------
546 -- Analyze_Expanded_Name --
547 ---------------------------
549 procedure Analyze_Expanded_Name
(N
: Node_Id
) is
551 -- If the entity pointer is already set, this is an internal node, or a
552 -- node that is analyzed more than once, after a tree modification. In
553 -- such a case there is no resolution to perform, just set the type. For
554 -- completeness, analyze prefix as well.
556 if Present
(Entity
(N
)) then
557 if Is_Type
(Entity
(N
)) then
558 Set_Etype
(N
, Entity
(N
));
560 Set_Etype
(N
, Etype
(Entity
(N
)));
563 Analyze
(Prefix
(N
));
566 Find_Expanded_Name
(N
);
568 end Analyze_Expanded_Name
;
570 ---------------------------------------
571 -- Analyze_Generic_Function_Renaming --
572 ---------------------------------------
574 procedure Analyze_Generic_Function_Renaming
(N
: Node_Id
) is
576 Analyze_Generic_Renaming
(N
, E_Generic_Function
);
577 end Analyze_Generic_Function_Renaming
;
579 --------------------------------------
580 -- Analyze_Generic_Package_Renaming --
581 --------------------------------------
583 procedure Analyze_Generic_Package_Renaming
(N
: Node_Id
) is
585 -- Apply the Text_IO Kludge here, since we may be renaming one of the
586 -- subpackages of Text_IO, then join common routine.
588 Text_IO_Kludge
(Name
(N
));
590 Analyze_Generic_Renaming
(N
, E_Generic_Package
);
591 end Analyze_Generic_Package_Renaming
;
593 ----------------------------------------
594 -- Analyze_Generic_Procedure_Renaming --
595 ----------------------------------------
597 procedure Analyze_Generic_Procedure_Renaming
(N
: Node_Id
) is
599 Analyze_Generic_Renaming
(N
, E_Generic_Procedure
);
600 end Analyze_Generic_Procedure_Renaming
;
602 ------------------------------
603 -- Analyze_Generic_Renaming --
604 ------------------------------
606 procedure Analyze_Generic_Renaming
610 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
612 Inst
: Boolean := False; -- prevent junk warning
615 if Name
(N
) = Error
then
619 Generate_Definition
(New_P
);
621 if Current_Scope
/= Standard_Standard
then
622 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
625 if Nkind
(Name
(N
)) = N_Selected_Component
then
626 Check_Generic_Child_Unit
(Name
(N
), Inst
);
631 if not Is_Entity_Name
(Name
(N
)) then
632 Error_Msg_N
("expect entity name in renaming declaration", Name
(N
));
635 Old_P
:= Entity
(Name
(N
));
639 Set_Ekind
(New_P
, K
);
641 if Etype
(Old_P
) = Any_Type
then
644 elsif Ekind
(Old_P
) /= K
then
645 Error_Msg_N
("invalid generic unit name", Name
(N
));
648 if Present
(Renamed_Object
(Old_P
)) then
649 Set_Renamed_Object
(New_P
, Renamed_Object
(Old_P
));
651 Set_Renamed_Object
(New_P
, Old_P
);
654 Set_Is_Pure
(New_P
, Is_Pure
(Old_P
));
655 Set_Is_Preelaborated
(New_P
, Is_Preelaborated
(Old_P
));
657 Set_Etype
(New_P
, Etype
(Old_P
));
658 Set_Has_Completion
(New_P
);
660 if In_Open_Scopes
(Old_P
) then
661 Error_Msg_N
("within its scope, generic denotes its instance", N
);
664 Check_Library_Unit_Renaming
(N
, Old_P
);
666 end Analyze_Generic_Renaming
;
668 -----------------------------
669 -- Analyze_Object_Renaming --
670 -----------------------------
672 procedure Analyze_Object_Renaming
(N
: Node_Id
) is
673 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
675 Nam
: constant Node_Id
:= Name
(N
);
679 function In_Generic_Scope
(E
: Entity_Id
) return Boolean;
680 -- Determine whether entity E is inside a generic cope
682 ----------------------
683 -- In_Generic_Scope --
684 ----------------------
686 function In_Generic_Scope
(E
: Entity_Id
) return Boolean is
691 while Present
(S
) and then S
/= Standard_Standard
loop
692 if Is_Generic_Unit
(S
) then
700 end In_Generic_Scope
;
702 -- Start of processing for Analyze_Object_Renaming
709 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
712 -- The renaming of a component that depends on a discriminant requires
713 -- an actual subtype, because in subsequent use of the object Gigi will
714 -- be unable to locate the actual bounds. This explicit step is required
715 -- when the renaming is generated in removing side effects of an
716 -- already-analyzed expression.
718 if Nkind
(Nam
) = N_Selected_Component
719 and then Analyzed
(Nam
)
722 Dec
:= Build_Actual_Subtype_Of_Component
(Etype
(Nam
), Nam
);
724 if Present
(Dec
) then
725 Insert_Action
(N
, Dec
);
726 T
:= Defining_Identifier
(Dec
);
730 -- Complete analysis of the subtype mark in any case, for ASIS use
732 if Present
(Subtype_Mark
(N
)) then
733 Find_Type
(Subtype_Mark
(N
));
736 elsif Present
(Subtype_Mark
(N
)) then
737 Find_Type
(Subtype_Mark
(N
));
738 T
:= Entity
(Subtype_Mark
(N
));
741 if Nkind
(Nam
) = N_Type_Conversion
742 and then not Is_Tagged_Type
(T
)
745 ("renaming of conversion only allowed for tagged types", Nam
);
750 -- Ada 2005 (AI-230/AI-254): Access renaming
752 else pragma Assert
(Present
(Access_Definition
(N
)));
753 T
:= Access_Definition
755 N
=> Access_Definition
(N
));
757 Analyze_And_Resolve
(Nam
, T
);
759 -- Ada 2005 (AI-231): "In the case where the type is defined by an
760 -- access_definition, the renamed entity shall be of an access-to-
761 -- constant type if and only if the access_definition defines an
762 -- access-to-constant type" ARM 8.5.1(4)
764 if Constant_Present
(Access_Definition
(N
))
765 and then not Is_Access_Constant
(Etype
(Nam
))
767 Error_Msg_N
("(Ada 2005): the renamed object is not "
768 & "access-to-constant (RM 8.5.1(6))", N
);
772 -- Special processing for renaming function return object
774 if Nkind
(Nam
) = N_Function_Call
775 and then Comes_From_Source
(Nam
)
779 -- Usage is illegal in Ada 83
783 ("(Ada 83) cannot rename function return object", Nam
);
785 -- In Ada 95, warn for odd case of renaming parameterless function
786 -- call if this is not a limited type (where this is useful)
789 if Warn_On_Object_Renames_Function
790 and then No
(Parameter_Associations
(Nam
))
791 and then not Is_Limited_Type
(Etype
(Nam
))
794 ("?renaming function result object is suspicious",
797 ("\?function & will be called only once",
798 Nam
, Entity
(Name
(Nam
)));
800 ("\?suggest using an initialized constant object instead",
806 -- An object renaming requires an exact match of the type. Class-wide
807 -- matching is not allowed.
809 if Is_Class_Wide_Type
(T
)
810 and then Base_Type
(Etype
(Nam
)) /= Base_Type
(T
)
817 -- (Ada 2005: AI-326): Handle wrong use of incomplete type
819 if Nkind
(Nam
) = N_Explicit_Dereference
820 and then Ekind
(Etype
(T2
)) = E_Incomplete_Type
822 Error_Msg_N
("invalid use of incomplete type", Id
);
828 if Ada_Version
>= Ada_05
829 and then Nkind
(Nam
) = N_Attribute_Reference
830 and then Attribute_Name
(Nam
) = Name_Priority
834 elsif Ada_Version
>= Ada_05
835 and then Nkind
(Nam
) in N_Has_Entity
838 Error_Node
: Node_Id
;
841 Subtyp_Decl
: Node_Id
;
844 if Nkind
(Nam
) = N_Attribute_Reference
then
845 Nam_Ent
:= Entity
(Prefix
(Nam
));
847 Nam_Ent
:= Entity
(Nam
);
850 Nam_Decl
:= Parent
(Nam_Ent
);
851 Subtyp_Decl
:= Parent
(Etype
(Nam_Ent
));
853 if Has_Null_Exclusion
(N
)
854 and then not Has_Null_Exclusion
(Nam_Decl
)
856 -- Ada 2005 (AI-423): If the object name denotes a generic
857 -- formal object of a generic unit G, and the object renaming
858 -- declaration occurs within the body of G or within the body
859 -- of a generic unit declared within the declarative region
860 -- of G, then the declaration of the formal object of G must
861 -- have a null exclusion.
863 if Is_Formal_Object
(Nam_Ent
)
864 and then In_Generic_Scope
(Id
)
866 if Present
(Subtype_Mark
(Nam_Decl
)) then
867 Error_Node
:= Subtype_Mark
(Nam_Decl
);
870 (Ada_Version
>= Ada_05
871 and then Present
(Access_Definition
(Nam_Decl
)));
873 Error_Node
:= Access_Definition
(Nam_Decl
);
877 ("`NOT NULL` required in formal object declaration",
879 Error_Msg_Sloc
:= Sloc
(N
);
881 ("\because of renaming # (RM 8.5.4(4))", Error_Node
);
883 -- Ada 2005 (AI-423): Otherwise, the subtype of the object name
884 -- shall exclude null.
886 elsif Nkind
(Subtyp_Decl
) = N_Subtype_Declaration
887 and then not Has_Null_Exclusion
(Subtyp_Decl
)
890 ("`NOT NULL` required for subtype & (RM 8.5.1(4.6/2))",
891 Defining_Identifier
(Subtyp_Decl
));
897 Set_Ekind
(Id
, E_Variable
);
898 Init_Size_Align
(Id
);
900 if T
= Any_Type
or else Etype
(Nam
) = Any_Type
then
903 -- Verify that the renamed entity is an object or a function call. It
904 -- may have been rewritten in several ways.
906 elsif Is_Object_Reference
(Nam
) then
907 if Comes_From_Source
(N
)
908 and then Is_Dependent_Component_Of_Mutable_Object
(Nam
)
911 ("illegal renaming of discriminant-dependent component", Nam
);
916 -- A static function call may have been folded into a literal
918 elsif Nkind
(Original_Node
(Nam
)) = N_Function_Call
920 -- When expansion is disabled, attribute reference is not
921 -- rewritten as function call. Otherwise it may be rewritten
922 -- as a conversion, so check original node.
924 or else (Nkind
(Original_Node
(Nam
)) = N_Attribute_Reference
925 and then Is_Function_Attribute_Name
926 (Attribute_Name
(Original_Node
(Nam
))))
928 -- Weird but legal, equivalent to renaming a function call.
929 -- Illegal if the literal is the result of constant-folding an
930 -- attribute reference that is not a function.
932 or else (Is_Entity_Name
(Nam
)
933 and then Ekind
(Entity
(Nam
)) = E_Enumeration_Literal
935 Nkind
(Original_Node
(Nam
)) /= N_Attribute_Reference
)
937 or else (Nkind
(Nam
) = N_Type_Conversion
938 and then Is_Tagged_Type
(Entity
(Subtype_Mark
(Nam
))))
942 elsif Nkind
(Nam
) = N_Type_Conversion
then
944 ("renaming of conversion only allowed for tagged types", Nam
);
948 elsif Ada_Version
>= Ada_05
949 and then Nkind
(Nam
) = N_Attribute_Reference
950 and then Attribute_Name
(Nam
) = Name_Priority
955 Error_Msg_N
("expect object name in renaming", Nam
);
960 if not Is_Variable
(Nam
) then
961 Set_Ekind
(Id
, E_Constant
);
962 Set_Never_Set_In_Source
(Id
, True);
963 Set_Is_True_Constant
(Id
, True);
966 Set_Renamed_Object
(Id
, Nam
);
967 end Analyze_Object_Renaming
;
969 ------------------------------
970 -- Analyze_Package_Renaming --
971 ------------------------------
973 procedure Analyze_Package_Renaming
(N
: Node_Id
) is
974 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
979 if Name
(N
) = Error
then
983 -- Apply Text_IO kludge here, since we may be renaming one of the
984 -- children of Text_IO.
986 Text_IO_Kludge
(Name
(N
));
988 if Current_Scope
/= Standard_Standard
then
989 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
995 if Is_Entity_Name
(Name
(N
)) then
996 Old_P
:= Entity
(Name
(N
));
1001 if Etype
(Old_P
) = Any_Type
then
1003 ("expect package name in renaming", Name
(N
));
1005 elsif Ekind
(Old_P
) /= E_Package
1006 and then not (Ekind
(Old_P
) = E_Generic_Package
1007 and then In_Open_Scopes
(Old_P
))
1009 if Ekind
(Old_P
) = E_Generic_Package
then
1011 ("generic package cannot be renamed as a package", Name
(N
));
1013 Error_Msg_Sloc
:= Sloc
(Old_P
);
1015 ("expect package name in renaming, found& declared#",
1019 -- Set basic attributes to minimize cascaded errors
1021 Set_Ekind
(New_P
, E_Package
);
1022 Set_Etype
(New_P
, Standard_Void_Type
);
1024 -- Here for OK package renaming
1027 -- Entities in the old package are accessible through the renaming
1028 -- entity. The simplest implementation is to have both packages share
1031 Set_Ekind
(New_P
, E_Package
);
1032 Set_Etype
(New_P
, Standard_Void_Type
);
1034 if Present
(Renamed_Object
(Old_P
)) then
1035 Set_Renamed_Object
(New_P
, Renamed_Object
(Old_P
));
1037 Set_Renamed_Object
(New_P
, Old_P
);
1040 Set_Has_Completion
(New_P
);
1042 Set_First_Entity
(New_P
, First_Entity
(Old_P
));
1043 Set_Last_Entity
(New_P
, Last_Entity
(Old_P
));
1044 Set_First_Private_Entity
(New_P
, First_Private_Entity
(Old_P
));
1045 Check_Library_Unit_Renaming
(N
, Old_P
);
1046 Generate_Reference
(Old_P
, Name
(N
));
1048 -- If the renaming is in the visible part of a package, then we set
1049 -- In_Package_Spec for the renamed package, to prevent giving
1050 -- warnings about no entities referenced. Such a warning would be
1051 -- overenthusiastic, since clients can see entities in the renamed
1052 -- package via the visible package renaming.
1055 Ent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
1057 if Ekind
(Ent
) = E_Package
1058 and then not In_Private_Part
(Ent
)
1059 and then In_Extended_Main_Source_Unit
(N
)
1060 and then Ekind
(Old_P
) = E_Package
1062 Set_Renamed_In_Spec
(Old_P
);
1066 -- If this is the renaming declaration of a package instantiation
1067 -- within itself, it is the declaration that ends the list of actuals
1068 -- for the instantiation. At this point, the subtypes that rename
1069 -- the actuals are flagged as generic, to avoid spurious ambiguities
1070 -- if the actuals for two distinct formals happen to coincide. If
1071 -- the actual is a private type, the subtype has a private completion
1072 -- that is flagged in the same fashion.
1074 -- Resolution is identical to what is was in the original generic.
1075 -- On exit from the generic instance, these are turned into regular
1076 -- subtypes again, so they are compatible with types in their class.
1078 if not Is_Generic_Instance
(Old_P
) then
1081 Spec
:= Specification
(Unit_Declaration_Node
(Old_P
));
1084 if Nkind
(Spec
) = N_Package_Specification
1085 and then Present
(Generic_Parent
(Spec
))
1086 and then Old_P
= Current_Scope
1087 and then Chars
(New_P
) = Chars
(Generic_Parent
(Spec
))
1093 E
:= First_Entity
(Old_P
);
1098 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
1100 Set_Is_Generic_Actual_Type
(E
);
1102 if Is_Private_Type
(E
)
1103 and then Present
(Full_View
(E
))
1105 Set_Is_Generic_Actual_Type
(Full_View
(E
));
1114 end Analyze_Package_Renaming
;
1116 -------------------------------
1117 -- Analyze_Renamed_Character --
1118 -------------------------------
1120 procedure Analyze_Renamed_Character
1125 C
: constant Node_Id
:= Name
(N
);
1128 if Ekind
(New_S
) = E_Function
then
1129 Resolve
(C
, Etype
(New_S
));
1132 Check_Frozen_Renaming
(N
, New_S
);
1136 Error_Msg_N
("character literal can only be renamed as function", N
);
1138 end Analyze_Renamed_Character
;
1140 ---------------------------------
1141 -- Analyze_Renamed_Dereference --
1142 ---------------------------------
1144 procedure Analyze_Renamed_Dereference
1149 Nam
: constant Node_Id
:= Name
(N
);
1150 P
: constant Node_Id
:= Prefix
(Nam
);
1156 if not Is_Overloaded
(P
) then
1157 if Ekind
(Etype
(Nam
)) /= E_Subprogram_Type
1158 or else not Type_Conformant
(Etype
(Nam
), New_S
) then
1159 Error_Msg_N
("designated type does not match specification", P
);
1168 Get_First_Interp
(Nam
, Ind
, It
);
1170 while Present
(It
.Nam
) loop
1172 if Ekind
(It
.Nam
) = E_Subprogram_Type
1173 and then Type_Conformant
(It
.Nam
, New_S
) then
1175 if Typ
/= Any_Id
then
1176 Error_Msg_N
("ambiguous renaming", P
);
1183 Get_Next_Interp
(Ind
, It
);
1186 if Typ
= Any_Type
then
1187 Error_Msg_N
("designated type does not match specification", P
);
1192 Check_Frozen_Renaming
(N
, New_S
);
1196 end Analyze_Renamed_Dereference
;
1198 ---------------------------
1199 -- Analyze_Renamed_Entry --
1200 ---------------------------
1202 procedure Analyze_Renamed_Entry
1207 Nam
: constant Node_Id
:= Name
(N
);
1208 Sel
: constant Node_Id
:= Selector_Name
(Nam
);
1212 if Entity
(Sel
) = Any_Id
then
1214 -- Selector is undefined on prefix. Error emitted already
1216 Set_Has_Completion
(New_S
);
1220 -- Otherwise find renamed entity and build body of New_S as a call to it
1222 Old_S
:= Find_Renamed_Entity
(N
, Selector_Name
(Nam
), New_S
);
1224 if Old_S
= Any_Id
then
1225 Error_Msg_N
(" no subprogram or entry matches specification", N
);
1228 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1229 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1230 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1233 -- Only mode conformance required for a renaming_as_declaration
1235 Check_Mode_Conformant
(New_S
, Old_S
, N
);
1238 Inherit_Renamed_Profile
(New_S
, Old_S
);
1240 -- The prefix can be an arbitrary expression that yields a task
1241 -- type, so it must be resolved.
1243 Resolve
(Prefix
(Nam
), Scope
(Old_S
));
1246 Set_Convention
(New_S
, Convention
(Old_S
));
1247 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1250 Check_Frozen_Renaming
(N
, New_S
);
1252 end Analyze_Renamed_Entry
;
1254 -----------------------------------
1255 -- Analyze_Renamed_Family_Member --
1256 -----------------------------------
1258 procedure Analyze_Renamed_Family_Member
1263 Nam
: constant Node_Id
:= Name
(N
);
1264 P
: constant Node_Id
:= Prefix
(Nam
);
1268 if (Is_Entity_Name
(P
) and then Ekind
(Entity
(P
)) = E_Entry_Family
)
1269 or else (Nkind
(P
) = N_Selected_Component
1271 Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
)
1273 if Is_Entity_Name
(P
) then
1274 Old_S
:= Entity
(P
);
1276 Old_S
:= Entity
(Selector_Name
(P
));
1279 if not Entity_Matches_Spec
(Old_S
, New_S
) then
1280 Error_Msg_N
("entry family does not match specification", N
);
1283 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1284 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1285 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1289 Error_Msg_N
("no entry family matches specification", N
);
1292 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1295 Check_Frozen_Renaming
(N
, New_S
);
1297 end Analyze_Renamed_Family_Member
;
1299 -----------------------------------------
1300 -- Analyze_Renamed_Primitive_Operation --
1301 -----------------------------------------
1303 procedure Analyze_Renamed_Primitive_Operation
1312 Ctyp
: Conformance_Type
) return Boolean;
1313 -- Verify that the signatures of the renamed entity and the new entity
1314 -- match. The first formal of the renamed entity is skipped because it
1315 -- is the target object in any subsequent call.
1319 Ctyp
: Conformance_Type
) return Boolean
1325 if Ekind
(Subp
) /= Ekind
(New_S
) then
1329 Old_F
:= Next_Formal
(First_Formal
(Subp
));
1330 New_F
:= First_Formal
(New_S
);
1331 while Present
(Old_F
) and then Present
(New_F
) loop
1332 if not Conforming_Types
(Etype
(Old_F
), Etype
(New_F
), Ctyp
) then
1336 if Ctyp
>= Mode_Conformant
1337 and then Ekind
(Old_F
) /= Ekind
(New_F
)
1342 Next_Formal
(New_F
);
1343 Next_Formal
(Old_F
);
1350 if not Is_Overloaded
(Selector_Name
(Name
(N
))) then
1351 Old_S
:= Entity
(Selector_Name
(Name
(N
)));
1353 if not Conforms
(Old_S
, Type_Conformant
) then
1358 -- Find the operation that matches the given signature
1366 Get_First_Interp
(Selector_Name
(Name
(N
)), Ind
, It
);
1368 while Present
(It
.Nam
) loop
1369 if Conforms
(It
.Nam
, Type_Conformant
) then
1373 Get_Next_Interp
(Ind
, It
);
1378 if Old_S
= Any_Id
then
1379 Error_Msg_N
(" no subprogram or entry matches specification", N
);
1383 if not Conforms
(Old_S
, Subtype_Conformant
) then
1384 Error_Msg_N
("subtype conformance error in renaming", N
);
1387 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1388 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1391 -- Only mode conformance required for a renaming_as_declaration
1393 if not Conforms
(Old_S
, Mode_Conformant
) then
1394 Error_Msg_N
("mode conformance error in renaming", N
);
1398 -- Inherit_Renamed_Profile (New_S, Old_S);
1400 -- The prefix can be an arbitrary expression that yields an
1401 -- object, so it must be resolved.
1403 Resolve
(Prefix
(Name
(N
)));
1405 end Analyze_Renamed_Primitive_Operation
;
1407 ---------------------------------
1408 -- Analyze_Subprogram_Renaming --
1409 ---------------------------------
1411 procedure Analyze_Subprogram_Renaming
(N
: Node_Id
) is
1412 Formal_Spec
: constant Node_Id
:= Corresponding_Formal_Spec
(N
);
1413 Is_Actual
: constant Boolean := Present
(Formal_Spec
);
1414 Inst_Node
: Node_Id
:= Empty
;
1415 Nam
: constant Node_Id
:= Name
(N
);
1417 Old_S
: Entity_Id
:= Empty
;
1418 Rename_Spec
: Entity_Id
;
1419 Save_AV
: constant Ada_Version_Type
:= Ada_Version
;
1420 Save_AV_Exp
: constant Ada_Version_Type
:= Ada_Version_Explicit
;
1421 Spec
: constant Node_Id
:= Specification
(N
);
1423 procedure Check_Null_Exclusion
1426 -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the
1427 -- following AI rules:
1429 -- If Ren is a renaming of a formal subprogram and one of its
1430 -- parameters has a null exclusion, then the corresponding formal
1431 -- in Sub must also have one. Otherwise the subtype of the Sub's
1432 -- formal parameter must exclude null.
1434 -- If Ren is a renaming of a formal function and its retrun
1435 -- profile has a null exclusion, then Sub's return profile must
1436 -- have one. Otherwise the subtype of Sub's return profile must
1439 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
;
1440 -- Find renamed entity when the declaration is a renaming_as_body and
1441 -- the renamed entity may itself be a renaming_as_body. Used to enforce
1442 -- rule that a renaming_as_body is illegal if the declaration occurs
1443 -- before the subprogram it completes is frozen, and renaming indirectly
1444 -- renames the subprogram itself.(Defect Report 8652/0027).
1446 --------------------------
1447 -- Check_Null_Exclusion --
1448 --------------------------
1450 procedure Check_Null_Exclusion
1454 Ren_Formal
: Entity_Id
;
1455 Sub_Formal
: Entity_Id
;
1460 Ren_Formal
:= First_Formal
(Ren
);
1461 Sub_Formal
:= First_Formal
(Sub
);
1462 while Present
(Ren_Formal
)
1463 and then Present
(Sub_Formal
)
1465 if Has_Null_Exclusion
(Parent
(Ren_Formal
))
1467 not (Has_Null_Exclusion
(Parent
(Sub_Formal
))
1468 or else Can_Never_Be_Null
(Etype
(Sub_Formal
)))
1471 ("`NOT NULL` required for parameter &",
1472 Parent
(Sub_Formal
), Sub_Formal
);
1475 Next_Formal
(Ren_Formal
);
1476 Next_Formal
(Sub_Formal
);
1479 -- Return profile check
1481 if Nkind
(Parent
(Ren
)) = N_Function_Specification
1482 and then Nkind
(Parent
(Sub
)) = N_Function_Specification
1483 and then Has_Null_Exclusion
(Parent
(Ren
))
1485 not (Has_Null_Exclusion
(Parent
(Sub
))
1486 or else Can_Never_Be_Null
(Etype
(Sub
)))
1489 ("return must specify `NOT NULL`",
1490 Result_Definition
(Parent
(Sub
)));
1492 end Check_Null_Exclusion
;
1494 -------------------------
1495 -- Original_Subprogram --
1496 -------------------------
1498 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
is
1499 Orig_Decl
: Node_Id
;
1500 Orig_Subp
: Entity_Id
;
1503 -- First case: renamed entity is itself a renaming
1505 if Present
(Alias
(Subp
)) then
1506 return Alias
(Subp
);
1509 Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
1511 (Corresponding_Body
(Unit_Declaration_Node
(Subp
)))
1513 -- Check if renamed entity is a renaming_as_body
1516 Unit_Declaration_Node
1517 (Corresponding_Body
(Unit_Declaration_Node
(Subp
)));
1519 if Nkind
(Orig_Decl
) = N_Subprogram_Renaming_Declaration
then
1520 Orig_Subp
:= Entity
(Name
(Orig_Decl
));
1522 if Orig_Subp
= Rename_Spec
then
1524 -- Circularity detected
1529 return (Original_Subprogram
(Orig_Subp
));
1537 end Original_Subprogram
;
1539 -- Start of processing for Analyze_Subprogram_Renaming
1542 -- We must test for the attribute renaming case before the Analyze
1543 -- call because otherwise Sem_Attr will complain that the attribute
1544 -- is missing an argument when it is analyzed.
1546 if Nkind
(Nam
) = N_Attribute_Reference
then
1548 -- In the case of an abstract formal subprogram association, rewrite
1549 -- an actual given by a stream attribute as the name of the
1550 -- corresponding stream primitive of the type.
1552 -- In a generic context the stream operations are not generated, and
1553 -- this must be treated as a normal attribute reference, to be
1554 -- expanded in subsequent instantiations.
1556 if Is_Actual
and then Is_Abstract_Subprogram
(Formal_Spec
)
1557 and then Expander_Active
1560 Stream_Prim
: Entity_Id
;
1561 Prefix_Type
: constant Entity_Id
:= Entity
(Prefix
(Nam
));
1564 -- The class-wide forms of the stream attributes are not
1565 -- primitive dispatching operations (even though they
1566 -- internally dispatch to a stream attribute).
1568 if Is_Class_Wide_Type
(Prefix_Type
) then
1570 ("attribute must be a primitive dispatching operation",
1575 -- Retrieve the primitive subprogram associated with the
1576 -- attribute. This can only be a stream attribute, since those
1577 -- are the only ones that are dispatching (and the actual for
1578 -- an abstract formal subprogram must be dispatching
1581 case Attribute_Name
(Nam
) is
1584 Find_Prim_Op
(Prefix_Type
, TSS_Stream_Input
);
1587 Find_Prim_Op
(Prefix_Type
, TSS_Stream_Output
);
1590 Find_Prim_Op
(Prefix_Type
, TSS_Stream_Read
);
1593 Find_Prim_Op
(Prefix_Type
, TSS_Stream_Write
);
1596 ("attribute must be a primitive dispatching operation",
1601 -- Rewrite the attribute into the name of its corresponding
1602 -- primitive dispatching subprogram. We can then proceed with
1603 -- the usual processing for subprogram renamings.
1606 Prim_Name
: constant Node_Id
:=
1607 Make_Identifier
(Sloc
(Nam
),
1608 Chars
=> Chars
(Stream_Prim
));
1610 Set_Entity
(Prim_Name
, Stream_Prim
);
1611 Rewrite
(Nam
, Prim_Name
);
1616 -- Normal processing for a renaming of an attribute
1619 Attribute_Renaming
(N
);
1624 -- Check whether this declaration corresponds to the instantiation
1625 -- of a formal subprogram.
1627 -- If this is an instantiation, the corresponding actual is frozen and
1628 -- error messages can be made more precise. If this is a default
1629 -- subprogram, the entity is already established in the generic, and is
1630 -- not retrieved by visibility. If it is a default with a box, the
1631 -- candidate interpretations, if any, have been collected when building
1632 -- the renaming declaration. If overloaded, the proper interpretation is
1633 -- determined in Find_Renamed_Entity. If the entity is an operator,
1634 -- Find_Renamed_Entity applies additional visibility checks.
1637 Inst_Node
:= Unit_Declaration_Node
(Formal_Spec
);
1639 if Is_Entity_Name
(Nam
)
1640 and then Present
(Entity
(Nam
))
1641 and then not Comes_From_Source
(Nam
)
1642 and then not Is_Overloaded
(Nam
)
1644 Old_S
:= Entity
(Nam
);
1645 New_S
:= Analyze_Subprogram_Specification
(Spec
);
1649 if Ekind
(Entity
(Nam
)) = E_Operator
then
1653 if Box_Present
(Inst_Node
) then
1654 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
1656 -- If there is an immediately visible homonym of the operator
1657 -- and the declaration has a default, this is worth a warning
1658 -- because the user probably did not intend to get the pre-
1659 -- defined operator, visible in the generic declaration. To
1660 -- find if there is an intended candidate, analyze the renaming
1661 -- again in the current context.
1663 elsif Scope
(Old_S
) = Standard_Standard
1664 and then Present
(Default_Name
(Inst_Node
))
1667 Decl
: constant Node_Id
:= New_Copy_Tree
(N
);
1671 Set_Entity
(Name
(Decl
), Empty
);
1672 Analyze
(Name
(Decl
));
1674 Find_Renamed_Entity
(Decl
, Name
(Decl
), New_S
, True);
1677 and then In_Open_Scopes
(Scope
(Hidden
))
1678 and then Is_Immediately_Visible
(Hidden
)
1679 and then Comes_From_Source
(Hidden
)
1680 and then Hidden
/= Old_S
1682 Error_Msg_Sloc
:= Sloc
(Hidden
);
1683 Error_Msg_N
("?default subprogram is resolved " &
1684 "in the generic declaration " &
1685 "(RM 12.6(17))", N
);
1686 Error_Msg_NE
("\?and will not use & #", N
, Hidden
);
1694 New_S
:= Analyze_Subprogram_Specification
(Spec
);
1698 -- Renamed entity must be analyzed first, to avoid being hidden by
1699 -- new name (which might be the same in a generic instance).
1703 -- The renaming defines a new overloaded entity, which is analyzed
1704 -- like a subprogram declaration.
1706 New_S
:= Analyze_Subprogram_Specification
(Spec
);
1709 if Current_Scope
/= Standard_Standard
then
1710 Set_Is_Pure
(New_S
, Is_Pure
(Current_Scope
));
1713 Rename_Spec
:= Find_Corresponding_Spec
(N
);
1715 -- Case of Renaming_As_Body
1717 if Present
(Rename_Spec
) then
1719 -- Renaming declaration is the completion of the declaration of
1720 -- Rename_Spec. We build an actual body for it at the freezing point.
1722 Set_Corresponding_Spec
(N
, Rename_Spec
);
1724 -- Deal with special case of Input and Output stream functions
1726 if Nkind
(Unit_Declaration_Node
(Rename_Spec
)) =
1727 N_Abstract_Subprogram_Declaration
1729 -- Input and Output stream functions are abstract if the object
1730 -- type is abstract. However, these functions may receive explicit
1731 -- declarations in representation clauses, making the attribute
1732 -- subprograms usable as defaults in subsequent type extensions.
1733 -- In this case we rewrite the declaration to make the subprogram
1734 -- non-abstract. We remove the previous declaration, and insert
1735 -- the new one at the point of the renaming, to prevent premature
1736 -- access to unfrozen types. The new declaration reuses the
1737 -- specification of the previous one, and must not be analyzed.
1739 pragma Assert
(Is_TSS
(Rename_Spec
, TSS_Stream_Output
)
1740 or else Is_TSS
(Rename_Spec
, TSS_Stream_Input
));
1743 Old_Decl
: constant Node_Id
:=
1744 Unit_Declaration_Node
(Rename_Spec
);
1745 New_Decl
: constant Node_Id
:=
1746 Make_Subprogram_Declaration
(Sloc
(N
),
1748 Relocate_Node
(Specification
(Old_Decl
)));
1751 Insert_After
(N
, New_Decl
);
1752 Set_Is_Abstract_Subprogram
(Rename_Spec
, False);
1753 Set_Analyzed
(New_Decl
);
1757 Set_Corresponding_Body
(Unit_Declaration_Node
(Rename_Spec
), New_S
);
1759 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
1760 Error_Msg_N
("(Ada 83) renaming cannot serve as a body", N
);
1763 Set_Convention
(New_S
, Convention
(Rename_Spec
));
1764 Check_Fully_Conformant
(New_S
, Rename_Spec
);
1765 Set_Public_Status
(New_S
);
1767 -- The specification does not introduce new formals, but only
1768 -- repeats the formals of the original subprogram declaration.
1769 -- For cross-reference purposes, and for refactoring tools, we
1770 -- treat the formals of the renaming declaration as body formals.
1772 Reference_Body_Formals
(Rename_Spec
, New_S
);
1774 -- Indicate that the entity in the declaration functions like the
1775 -- corresponding body, and is not a new entity. The body will be
1776 -- constructed later at the freeze point, so indicate that the
1777 -- completion has not been seen yet.
1779 Set_Ekind
(New_S
, E_Subprogram_Body
);
1780 New_S
:= Rename_Spec
;
1781 Set_Has_Completion
(Rename_Spec
, False);
1783 -- Ada 2005: check overriding indicator
1785 if Must_Override
(Specification
(N
))
1786 and then not Is_Overriding_Operation
(Rename_Spec
)
1788 Error_Msg_NE
("subprogram& is not overriding", N
, Rename_Spec
);
1790 elsif Must_Not_Override
(Specification
(N
))
1791 and then Is_Overriding_Operation
(Rename_Spec
)
1794 ("subprogram& overrides inherited operation", N
, Rename_Spec
);
1797 -- Normal subprogram renaming (not renaming as body)
1800 Generate_Definition
(New_S
);
1801 New_Overloaded_Entity
(New_S
);
1803 if Is_Entity_Name
(Nam
)
1804 and then Is_Intrinsic_Subprogram
(Entity
(Nam
))
1808 Check_Delayed_Subprogram
(New_S
);
1812 -- There is no need for elaboration checks on the new entity, which may
1813 -- be called before the next freezing point where the body will appear.
1814 -- Elaboration checks refer to the real entity, not the one created by
1815 -- the renaming declaration.
1817 Set_Kill_Elaboration_Checks
(New_S
, True);
1819 if Etype
(Nam
) = Any_Type
then
1820 Set_Has_Completion
(New_S
);
1823 elsif Nkind
(Nam
) = N_Selected_Component
then
1825 -- A prefix of the form A.B can designate an entry of task A, a
1826 -- protected operation of protected object A, or finally a primitive
1827 -- operation of object A. In the later case, A is an object of some
1828 -- tagged type, or an access type that denotes one such. To further
1829 -- distinguish these cases, note that the scope of a task entry or
1830 -- protected operation is type of the prefix.
1832 -- The prefix could be an overloaded function call that returns both
1833 -- kinds of operations. This overloading pathology is left to the
1834 -- dedicated reader ???
1837 T
: constant Entity_Id
:= Etype
(Prefix
(Nam
));
1846 Is_Tagged_Type
(Designated_Type
(T
))))
1847 and then Scope
(Entity
(Selector_Name
(Nam
))) /= T
1849 Analyze_Renamed_Primitive_Operation
1850 (N
, New_S
, Present
(Rename_Spec
));
1854 -- Renamed entity is an entry or protected operation. For those
1855 -- cases an explicit body is built (at the point of freezing of
1856 -- this entity) that contains a call to the renamed entity.
1858 -- This is not allowed for renaming as body if the renamed
1859 -- spec is already frozen (see RM 8.5.4(5) for details).
1861 if Present
(Rename_Spec
)
1862 and then Is_Frozen
(Rename_Spec
)
1865 ("renaming-as-body cannot rename entry as subprogram", N
);
1867 ("\since & is already frozen (RM 8.5.4(5))",
1870 Analyze_Renamed_Entry
(N
, New_S
, Present
(Rename_Spec
));
1877 elsif Nkind
(Nam
) = N_Explicit_Dereference
then
1879 -- Renamed entity is designated by access_to_subprogram expression.
1880 -- Must build body to encapsulate call, as in the entry case.
1882 Analyze_Renamed_Dereference
(N
, New_S
, Present
(Rename_Spec
));
1885 elsif Nkind
(Nam
) = N_Indexed_Component
then
1886 Analyze_Renamed_Family_Member
(N
, New_S
, Present
(Rename_Spec
));
1889 elsif Nkind
(Nam
) = N_Character_Literal
then
1890 Analyze_Renamed_Character
(N
, New_S
, Present
(Rename_Spec
));
1893 elsif (not Is_Entity_Name
(Nam
)
1894 and then Nkind
(Nam
) /= N_Operator_Symbol
)
1895 or else not Is_Overloadable
(Entity
(Nam
))
1897 Error_Msg_N
("expect valid subprogram name in renaming", N
);
1901 -- Find the renamed entity that matches the given specification. Disable
1902 -- Ada_83 because there is no requirement of full conformance between
1903 -- renamed entity and new entity, even though the same circuit is used.
1905 -- This is a bit of a kludge, which introduces a really irregular use of
1906 -- Ada_Version[_Explicit]. Would be nice to find cleaner way to do this
1909 Ada_Version
:= Ada_Version_Type
'Max (Ada_Version
, Ada_95
);
1910 Ada_Version_Explicit
:= Ada_Version
;
1913 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
1915 -- When the renamed subprogram is overloaded and used as an actual
1916 -- of a generic, its entity is set to the first available homonym.
1917 -- We must first disambiguate the name, then set the proper entity.
1920 and then Is_Overloaded
(Nam
)
1922 Set_Entity
(Nam
, Old_S
);
1926 -- Most common case: subprogram renames subprogram. No body is generated
1927 -- in this case, so we must indicate the declaration is complete as is.
1929 if No
(Rename_Spec
) then
1930 Set_Has_Completion
(New_S
);
1931 Set_Is_Pure
(New_S
, Is_Pure
(Entity
(Nam
)));
1932 Set_Is_Preelaborated
(New_S
, Is_Preelaborated
(Entity
(Nam
)));
1934 -- Ada 2005 (AI-423): Check the consistency of null exclusions
1935 -- between a subprogram and its correct renaming.
1937 -- Note: the Any_Id check is a guard that prevents compiler crashes
1938 -- when performing a null exclusion check between a renaming and a
1939 -- renamed subprogram that has been found to be illegal.
1941 if Ada_Version
>= Ada_05
1942 and then Entity
(Nam
) /= Any_Id
1944 Check_Null_Exclusion
1946 Sub
=> Entity
(Nam
));
1949 -- Enforce the Ada 2005 rule that the renamed entity cannot require
1950 -- overriding. The flag Requires_Overriding is set very selectively
1951 -- and misses some other illegal cases. The additional conditions
1952 -- checked below are sufficient but not necessary ???
1954 -- The rule does not apply to the renaming generated for an actual
1955 -- subprogram in an instance.
1960 -- Guard agaisnt previous errors, and omit renamings of predefined
1963 elsif Ekind
(Old_S
) /= E_Function
1964 and then Ekind
(Old_S
) /= E_Procedure
1968 elsif Requires_Overriding
(Old_S
)
1970 (Is_Abstract_Subprogram
(Old_S
)
1971 and then Present
(Find_Dispatching_Type
(Old_S
))
1973 not Is_Abstract_Type
(Find_Dispatching_Type
(Old_S
)))
1976 ("renamed entity cannot be "
1977 & "subprogram that requires overriding (RM 8.5.4 (5.1))", N
);
1981 if Old_S
/= Any_Id
then
1983 and then From_Default
(N
)
1985 -- This is an implicit reference to the default actual
1987 Generate_Reference
(Old_S
, Nam
, Typ
=> 'i', Force
=> True);
1989 Generate_Reference
(Old_S
, Nam
);
1992 -- For a renaming-as-body, require subtype conformance, but if the
1993 -- declaration being completed has not been frozen, then inherit the
1994 -- convention of the renamed subprogram prior to checking conformance
1995 -- (unless the renaming has an explicit convention established; the
1996 -- rule stated in the RM doesn't seem to address this ???).
1998 if Present
(Rename_Spec
) then
1999 Generate_Reference
(Rename_Spec
, Defining_Entity
(Spec
), 'b');
2000 Style
.Check_Identifier
(Defining_Entity
(Spec
), Rename_Spec
);
2002 if not Is_Frozen
(Rename_Spec
) then
2003 if not Has_Convention_Pragma
(Rename_Spec
) then
2004 Set_Convention
(New_S
, Convention
(Old_S
));
2007 if Ekind
(Old_S
) /= E_Operator
then
2008 Check_Mode_Conformant
(New_S
, Old_S
, Spec
);
2011 if Original_Subprogram
(Old_S
) = Rename_Spec
then
2012 Error_Msg_N
("unfrozen subprogram cannot rename itself ", N
);
2015 Check_Subtype_Conformant
(New_S
, Old_S
, Spec
);
2018 Check_Frozen_Renaming
(N
, Rename_Spec
);
2020 -- Check explicitly that renamed entity is not intrinsic, because
2021 -- in in a generic the renamed body is not built. In this case,
2022 -- the renaming_as_body is a completion.
2024 if Inside_A_Generic
then
2025 if Is_Frozen
(Rename_Spec
)
2026 and then Is_Intrinsic_Subprogram
(Old_S
)
2029 ("subprogram in renaming_as_body cannot be intrinsic",
2033 Set_Has_Completion
(Rename_Spec
);
2036 elsif Ekind
(Old_S
) /= E_Operator
then
2037 Check_Mode_Conformant
(New_S
, Old_S
);
2040 and then Error_Posted
(New_S
)
2042 Error_Msg_NE
("invalid actual subprogram: & #!", N
, Old_S
);
2046 if No
(Rename_Spec
) then
2048 -- The parameter profile of the new entity is that of the renamed
2049 -- entity: the subtypes given in the specification are irrelevant.
2051 Inherit_Renamed_Profile
(New_S
, Old_S
);
2053 -- A call to the subprogram is transformed into a call to the
2054 -- renamed entity. This is transitive if the renamed entity is
2055 -- itself a renaming.
2057 if Present
(Alias
(Old_S
)) then
2058 Set_Alias
(New_S
, Alias
(Old_S
));
2060 Set_Alias
(New_S
, Old_S
);
2063 -- Note that we do not set Is_Intrinsic_Subprogram if we have a
2064 -- renaming as body, since the entity in this case is not an
2065 -- intrinsic (it calls an intrinsic, but we have a real body for
2066 -- this call, and it is in this body that the required intrinsic
2067 -- processing will take place).
2069 -- Also, if this is a renaming of inequality, the renamed operator
2070 -- is intrinsic, but what matters is the corresponding equality
2071 -- operator, which may be user-defined.
2073 Set_Is_Intrinsic_Subprogram
2075 Is_Intrinsic_Subprogram
(Old_S
)
2077 (Chars
(Old_S
) /= Name_Op_Ne
2078 or else Ekind
(Old_S
) = E_Operator
2080 Is_Intrinsic_Subprogram
2081 (Corresponding_Equality
(Old_S
))));
2083 if Ekind
(Alias
(New_S
)) = E_Operator
then
2084 Set_Has_Delayed_Freeze
(New_S
, False);
2087 -- If the renaming corresponds to an association for an abstract
2088 -- formal subprogram, then various attributes must be set to
2089 -- indicate that the renaming is an abstract dispatching operation
2090 -- with a controlling type.
2092 if Is_Actual
and then Is_Abstract_Subprogram
(Formal_Spec
) then
2094 -- Mark the renaming as abstract here, so Find_Dispatching_Type
2095 -- see it as corresponding to a generic association for a
2096 -- formal abstract subprogram
2098 Set_Is_Abstract_Subprogram
(New_S
);
2101 New_S_Ctrl_Type
: constant Entity_Id
:=
2102 Find_Dispatching_Type
(New_S
);
2103 Old_S_Ctrl_Type
: constant Entity_Id
:=
2104 Find_Dispatching_Type
(Old_S
);
2107 if Old_S_Ctrl_Type
/= New_S_Ctrl_Type
then
2109 ("actual must be dispatching subprogram for type&",
2110 Nam
, New_S_Ctrl_Type
);
2113 Set_Is_Dispatching_Operation
(New_S
);
2114 Check_Controlling_Formals
(New_S_Ctrl_Type
, New_S
);
2116 -- If the actual in the formal subprogram is itself a
2117 -- formal abstract subprogram association, there's no
2118 -- dispatch table component or position to inherit.
2120 if Present
(DTC_Entity
(Old_S
)) then
2121 Set_DTC_Entity
(New_S
, DTC_Entity
(Old_S
));
2122 Set_DT_Position
(New_S
, DT_Position
(Old_S
));
2130 and then (Old_S
= New_S
2131 or else (Nkind
(Nam
) /= N_Expanded_Name
2132 and then Chars
(Old_S
) = Chars
(New_S
)))
2134 Error_Msg_N
("subprogram cannot rename itself", N
);
2137 Set_Convention
(New_S
, Convention
(Old_S
));
2139 if Is_Abstract_Subprogram
(Old_S
) then
2140 if Present
(Rename_Spec
) then
2142 ("a renaming-as-body cannot rename an abstract subprogram",
2144 Set_Has_Completion
(Rename_Spec
);
2146 Set_Is_Abstract_Subprogram
(New_S
);
2150 Check_Library_Unit_Renaming
(N
, Old_S
);
2152 -- Pathological case: procedure renames entry in the scope of its
2153 -- task. Entry is given by simple name, but body must be built for
2154 -- procedure. Of course if called it will deadlock.
2156 if Ekind
(Old_S
) = E_Entry
then
2157 Set_Has_Completion
(New_S
, False);
2158 Set_Alias
(New_S
, Empty
);
2162 Freeze_Before
(N
, Old_S
);
2163 Set_Has_Delayed_Freeze
(New_S
, False);
2164 Freeze_Before
(N
, New_S
);
2166 -- An abstract subprogram is only allowed as an actual in the case
2167 -- where the formal subprogram is also abstract.
2169 if (Ekind
(Old_S
) = E_Procedure
or else Ekind
(Old_S
) = E_Function
)
2170 and then Is_Abstract_Subprogram
(Old_S
)
2171 and then not Is_Abstract_Subprogram
(Formal_Spec
)
2174 ("abstract subprogram not allowed as generic actual", Nam
);
2179 -- A common error is to assume that implicit operators for types are
2180 -- defined in Standard, or in the scope of a subtype. In those cases
2181 -- where the renamed entity is given with an expanded name, it is
2182 -- worth mentioning that operators for the type are not declared in
2183 -- the scope given by the prefix.
2185 if Nkind
(Nam
) = N_Expanded_Name
2186 and then Nkind
(Selector_Name
(Nam
)) = N_Operator_Symbol
2187 and then Scope
(Entity
(Nam
)) = Standard_Standard
2190 T
: constant Entity_Id
:=
2191 Base_Type
(Etype
(First_Formal
(New_S
)));
2193 Error_Msg_Node_2
:= Prefix
(Nam
);
2195 ("operator for type& is not declared in&", Prefix
(Nam
), T
);
2200 ("no visible subprogram matches the specification for&",
2204 if Present
(Candidate_Renaming
) then
2210 F1
:= First_Formal
(Candidate_Renaming
);
2211 F2
:= First_Formal
(New_S
);
2213 while Present
(F1
) and then Present
(F2
) loop
2218 if Present
(F1
) and then Present
(Default_Value
(F1
)) then
2219 if Present
(Next_Formal
(F1
)) then
2221 ("\missing specification for &" &
2222 " and other formals with defaults", Spec
, F1
);
2225 ("\missing specification for &", Spec
, F1
);
2232 -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that
2233 -- controlling access parameters are known non-null for the renamed
2234 -- subprogram. Test also applies to a subprogram instantiation that
2235 -- is dispatching. Test is skipped if some previous error was detected
2236 -- that set Old_S to Any_Id.
2238 if Ada_Version
>= Ada_05
2239 and then Old_S
/= Any_Id
2240 and then not Is_Dispatching_Operation
(Old_S
)
2241 and then Is_Dispatching_Operation
(New_S
)
2248 Old_F
:= First_Formal
(Old_S
);
2249 New_F
:= First_Formal
(New_S
);
2250 while Present
(Old_F
) loop
2251 if Ekind
(Etype
(Old_F
)) = E_Anonymous_Access_Type
2252 and then Is_Controlling_Formal
(New_F
)
2253 and then not Can_Never_Be_Null
(Old_F
)
2255 Error_Msg_N
("access parameter is controlling,", New_F
);
2257 ("\corresponding parameter of& "
2258 & "must be explicitly null excluding", New_F
, Old_S
);
2261 Next_Formal
(Old_F
);
2262 Next_Formal
(New_F
);
2267 -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005)
2269 if Comes_From_Source
(N
)
2270 and then Present
(Old_S
)
2271 and then Nkind
(Old_S
) = N_Defining_Operator_Symbol
2272 and then Nkind
(New_S
) = N_Defining_Operator_Symbol
2273 and then Chars
(Old_S
) /= Chars
(New_S
)
2276 ("?& is being renamed as a different operator",
2280 -- Another warning or some utility: if the new subprogram as the same
2281 -- name as the old one, the old one is not hidden by an outer homograph,
2282 -- the new one is not a public symbol, and the old one is otherwise
2283 -- directly visible, the renaming is superfluous.
2285 if Chars
(Old_S
) = Chars
(New_S
)
2286 and then Comes_From_Source
(N
)
2287 and then Scope
(Old_S
) /= Standard_Standard
2288 and then Warn_On_Redundant_Constructs
2290 (Is_Immediately_Visible
(Old_S
)
2291 or else Is_Potentially_Use_Visible
(Old_S
))
2292 and then Is_Overloadable
(Current_Scope
)
2293 and then Chars
(Current_Scope
) /= Chars
(Old_S
)
2296 ("?redundant renaming, entity is directly visible", Name
(N
));
2299 Ada_Version
:= Save_AV
;
2300 Ada_Version_Explicit
:= Save_AV_Exp
;
2301 end Analyze_Subprogram_Renaming
;
2303 -------------------------
2304 -- Analyze_Use_Package --
2305 -------------------------
2307 -- Resolve the package names in the use clause, and make all the visible
2308 -- entities defined in the package potentially use-visible. If the package
2309 -- is already in use from a previous use clause, its visible entities are
2310 -- already use-visible. In that case, mark the occurrence as a redundant
2311 -- use. If the package is an open scope, i.e. if the use clause occurs
2312 -- within the package itself, ignore it.
2314 procedure Analyze_Use_Package
(N
: Node_Id
) is
2315 Pack_Name
: Node_Id
;
2318 -- Start of processing for Analyze_Use_Package
2321 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
2323 -- Use clause is not allowed in a spec of a predefined package
2324 -- declaration except that packages whose file name starts a-n are OK
2325 -- (these are children of Ada.Numerics, and such packages are never
2326 -- loaded by Rtsfind).
2328 if Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
2329 and then Name_Buffer
(1 .. 3) /= "a-n"
2331 Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
2333 Error_Msg_N
("use clause not allowed in predefined spec", N
);
2336 -- Chain clause to list of use clauses in current scope
2338 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
2339 Chain_Use_Clause
(N
);
2342 -- Loop through package names to identify referenced packages
2344 Pack_Name
:= First
(Names
(N
));
2345 while Present
(Pack_Name
) loop
2346 Analyze
(Pack_Name
);
2348 if Nkind
(Parent
(N
)) = N_Compilation_Unit
2349 and then Nkind
(Pack_Name
) = N_Expanded_Name
2355 Pref
:= Prefix
(Pack_Name
);
2356 while Nkind
(Pref
) = N_Expanded_Name
loop
2357 Pref
:= Prefix
(Pref
);
2360 if Entity
(Pref
) = Standard_Standard
then
2362 ("predefined package Standard cannot appear"
2363 & " in a context clause", Pref
);
2371 -- Loop through package names to mark all entities as potentially
2374 Pack_Name
:= First
(Names
(N
));
2375 while Present
(Pack_Name
) loop
2376 if Is_Entity_Name
(Pack_Name
) then
2377 Pack
:= Entity
(Pack_Name
);
2379 if Ekind
(Pack
) /= E_Package
2380 and then Etype
(Pack
) /= Any_Type
2382 if Ekind
(Pack
) = E_Generic_Package
then
2384 ("a generic package is not allowed in a use clause",
2387 Error_Msg_N
("& is not a usable package", Pack_Name
);
2391 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
2392 Check_In_Previous_With_Clause
(N
, Pack_Name
);
2395 if Applicable_Use
(Pack_Name
) then
2396 Use_One_Package
(Pack
, N
);
2403 end Analyze_Use_Package
;
2405 ----------------------
2406 -- Analyze_Use_Type --
2407 ----------------------
2409 procedure Analyze_Use_Type
(N
: Node_Id
) is
2414 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
2416 -- Chain clause to list of use clauses in current scope
2418 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
2419 Chain_Use_Clause
(N
);
2422 Id
:= First
(Subtype_Marks
(N
));
2423 while Present
(Id
) loop
2427 if E
/= Any_Type
then
2430 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
2431 if Nkind
(Id
) = N_Identifier
then
2432 Error_Msg_N
("type is not directly visible", Id
);
2434 elsif Is_Child_Unit
(Scope
(E
))
2435 and then Scope
(E
) /= System_Aux_Id
2437 Check_In_Previous_With_Clause
(N
, Prefix
(Id
));
2444 end Analyze_Use_Type
;
2446 --------------------
2447 -- Applicable_Use --
2448 --------------------
2450 function Applicable_Use
(Pack_Name
: Node_Id
) return Boolean is
2451 Pack
: constant Entity_Id
:= Entity
(Pack_Name
);
2454 if In_Open_Scopes
(Pack
) then
2455 if Warn_On_Redundant_Constructs
2456 and then Pack
= Current_Scope
2459 ("& is already use-visible within itself?", Pack_Name
, Pack
);
2464 elsif In_Use
(Pack
) then
2465 Note_Redundant_Use
(Pack_Name
);
2468 elsif Present
(Renamed_Object
(Pack
))
2469 and then In_Use
(Renamed_Object
(Pack
))
2471 Note_Redundant_Use
(Pack_Name
);
2479 ------------------------
2480 -- Attribute_Renaming --
2481 ------------------------
2483 procedure Attribute_Renaming
(N
: Node_Id
) is
2484 Loc
: constant Source_Ptr
:= Sloc
(N
);
2485 Nam
: constant Node_Id
:= Name
(N
);
2486 Spec
: constant Node_Id
:= Specification
(N
);
2487 New_S
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
2488 Aname
: constant Name_Id
:= Attribute_Name
(Nam
);
2490 Form_Num
: Nat
:= 0;
2491 Expr_List
: List_Id
:= No_List
;
2493 Attr_Node
: Node_Id
;
2494 Body_Node
: Node_Id
;
2495 Param_Spec
: Node_Id
;
2498 Generate_Definition
(New_S
);
2500 -- This procedure is called in the context of subprogram renaming,
2501 -- and thus the attribute must be one that is a subprogram. All of
2502 -- those have at least one formal parameter, with the singular
2503 -- exception of AST_Entry (which is a real oddity, it is odd that
2504 -- this can be renamed at all!)
2506 if not Is_Non_Empty_List
(Parameter_Specifications
(Spec
)) then
2507 if Aname
/= Name_AST_Entry
then
2509 ("subprogram renaming an attribute must have formals", N
);
2514 Param_Spec
:= First
(Parameter_Specifications
(Spec
));
2515 while Present
(Param_Spec
) loop
2516 Form_Num
:= Form_Num
+ 1;
2518 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
2519 Find_Type
(Parameter_Type
(Param_Spec
));
2521 -- The profile of the new entity denotes the base type (s) of
2522 -- the types given in the specification. For access parameters
2523 -- there are no subtypes involved.
2525 Rewrite
(Parameter_Type
(Param_Spec
),
2527 (Base_Type
(Entity
(Parameter_Type
(Param_Spec
))), Loc
));
2530 if No
(Expr_List
) then
2531 Expr_List
:= New_List
;
2534 Append_To
(Expr_List
,
2535 Make_Identifier
(Loc
,
2536 Chars
=> Chars
(Defining_Identifier
(Param_Spec
))));
2538 -- The expressions in the attribute reference are not freeze
2539 -- points. Neither is the attribute as a whole, see below.
2541 Set_Must_Not_Freeze
(Last
(Expr_List
));
2546 -- Immediate error if too many formals. Other mismatches in numbers
2547 -- of number of types of parameters are detected when we analyze the
2548 -- body of the subprogram that we construct.
2550 if Form_Num
> 2 then
2551 Error_Msg_N
("too many formals for attribute", N
);
2553 -- Error if the attribute reference has expressions that look
2554 -- like formal parameters.
2556 elsif Present
(Expressions
(Nam
)) then
2557 Error_Msg_N
("illegal expressions in attribute reference", Nam
);
2560 Aname
= Name_Compose
or else
2561 Aname
= Name_Exponent
or else
2562 Aname
= Name_Leading_Part
or else
2563 Aname
= Name_Pos
or else
2564 Aname
= Name_Round
or else
2565 Aname
= Name_Scaling
or else
2568 if Nkind
(N
) = N_Subprogram_Renaming_Declaration
2569 and then Present
(Corresponding_Formal_Spec
(N
))
2572 ("generic actual cannot be attribute involving universal type",
2576 ("attribute involving a universal type cannot be renamed",
2581 -- AST_Entry is an odd case. It doesn't really make much sense to
2582 -- allow it to be renamed, but that's the DEC rule, so we have to
2583 -- do it right. The point is that the AST_Entry call should be made
2584 -- now, and what the function will return is the returned value.
2586 -- Note that there is no Expr_List in this case anyway
2588 if Aname
= Name_AST_Entry
then
2594 Ent
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
2597 Make_Object_Declaration
(Loc
,
2598 Defining_Identifier
=> Ent
,
2599 Object_Definition
=>
2600 New_Occurrence_Of
(RTE
(RE_AST_Handler
), Loc
),
2602 Constant_Present
=> True);
2604 Set_Assignment_OK
(Decl
, True);
2605 Insert_Action
(N
, Decl
);
2606 Attr_Node
:= Make_Identifier
(Loc
, Chars
(Ent
));
2609 -- For all other attributes, we rewrite the attribute node to have
2610 -- a list of expressions corresponding to the subprogram formals.
2611 -- A renaming declaration is not a freeze point, and the analysis of
2612 -- the attribute reference should not freeze the type of the prefix.
2616 Make_Attribute_Reference
(Loc
,
2617 Prefix
=> Prefix
(Nam
),
2618 Attribute_Name
=> Aname
,
2619 Expressions
=> Expr_List
);
2621 Set_Must_Not_Freeze
(Attr_Node
);
2622 Set_Must_Not_Freeze
(Prefix
(Nam
));
2625 -- Case of renaming a function
2627 if Nkind
(Spec
) = N_Function_Specification
then
2628 if Is_Procedure_Attribute_Name
(Aname
) then
2629 Error_Msg_N
("attribute can only be renamed as procedure", Nam
);
2633 Find_Type
(Result_Definition
(Spec
));
2634 Rewrite
(Result_Definition
(Spec
),
2636 Base_Type
(Entity
(Result_Definition
(Spec
))), Loc
));
2639 Make_Subprogram_Body
(Loc
,
2640 Specification
=> Spec
,
2641 Declarations
=> New_List
,
2642 Handled_Statement_Sequence
=>
2643 Make_Handled_Sequence_Of_Statements
(Loc
,
2644 Statements
=> New_List
(
2645 Make_Simple_Return_Statement
(Loc
,
2646 Expression
=> Attr_Node
))));
2648 -- Case of renaming a procedure
2651 if not Is_Procedure_Attribute_Name
(Aname
) then
2652 Error_Msg_N
("attribute can only be renamed as function", Nam
);
2657 Make_Subprogram_Body
(Loc
,
2658 Specification
=> Spec
,
2659 Declarations
=> New_List
,
2660 Handled_Statement_Sequence
=>
2661 Make_Handled_Sequence_Of_Statements
(Loc
,
2662 Statements
=> New_List
(Attr_Node
)));
2665 -- In case of tagged types we add the body of the generated function to
2666 -- the freezing actions of the type (because in the general case such
2667 -- type is still not frozen). We exclude from this processing generic
2668 -- formal subprograms found in instantiations and AST_Entry renamings.
2670 if not Present
(Corresponding_Formal_Spec
(N
))
2671 and then Etype
(Nam
) /= RTE
(RE_AST_Handler
)
2674 P
: constant Entity_Id
:= Prefix
(Nam
);
2679 if Is_Tagged_Type
(Etype
(P
)) then
2680 Ensure_Freeze_Node
(Etype
(P
));
2681 Append_Freeze_Action
(Etype
(P
), Body_Node
);
2683 Rewrite
(N
, Body_Node
);
2685 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
2689 -- Generic formal subprograms or AST_Handler renaming
2692 Rewrite
(N
, Body_Node
);
2694 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
2697 if Is_Compilation_Unit
(New_S
) then
2699 ("a library unit can only rename another library unit", N
);
2702 -- We suppress elaboration warnings for the resulting entity, since
2703 -- clearly they are not needed, and more particularly, in the case
2704 -- of a generic formal subprogram, the resulting entity can appear
2705 -- after the instantiation itself, and thus look like a bogus case
2706 -- of access before elaboration.
2708 Set_Suppress_Elaboration_Warnings
(New_S
);
2710 end Attribute_Renaming
;
2712 ----------------------
2713 -- Chain_Use_Clause --
2714 ----------------------
2716 procedure Chain_Use_Clause
(N
: Node_Id
) is
2718 Level
: Int
:= Scope_Stack
.Last
;
2721 if not Is_Compilation_Unit
(Current_Scope
)
2722 or else not Is_Child_Unit
(Current_Scope
)
2724 null; -- Common case
2726 elsif Defining_Entity
(Parent
(N
)) = Current_Scope
then
2727 null; -- Common case for compilation unit
2730 -- If declaration appears in some other scope, it must be in some
2731 -- parent unit when compiling a child.
2733 Pack
:= Defining_Entity
(Parent
(N
));
2734 if not In_Open_Scopes
(Pack
) then
2735 null; -- default as well
2738 -- Find entry for parent unit in scope stack
2740 while Scope_Stack
.Table
(Level
).Entity
/= Pack
loop
2746 Set_Next_Use_Clause
(N
,
2747 Scope_Stack
.Table
(Level
).First_Use_Clause
);
2748 Scope_Stack
.Table
(Level
).First_Use_Clause
:= N
;
2749 end Chain_Use_Clause
;
2751 ---------------------------
2752 -- Check_Frozen_Renaming --
2753 ---------------------------
2755 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
) is
2761 and then not Has_Completion
(Subp
)
2765 (Parent
(Declaration_Node
(Subp
)), Defining_Entity
(N
));
2767 if Is_Entity_Name
(Name
(N
)) then
2768 Old_S
:= Entity
(Name
(N
));
2770 if not Is_Frozen
(Old_S
)
2771 and then Operating_Mode
/= Check_Semantics
2773 Append_Freeze_Action
(Old_S
, B_Node
);
2775 Insert_After
(N
, B_Node
);
2779 if Is_Intrinsic_Subprogram
(Old_S
)
2780 and then not In_Instance
2783 ("subprogram used in renaming_as_body cannot be intrinsic",
2788 Insert_After
(N
, B_Node
);
2792 end Check_Frozen_Renaming
;
2794 -----------------------------------
2795 -- Check_In_Previous_With_Clause --
2796 -----------------------------------
2798 procedure Check_In_Previous_With_Clause
2802 Pack
: constant Entity_Id
:= Entity
(Original_Node
(Nam
));
2807 Item
:= First
(Context_Items
(Parent
(N
)));
2809 while Present
(Item
)
2812 if Nkind
(Item
) = N_With_Clause
2814 -- Protect the frontend against previous critical errors
2816 and then Nkind
(Name
(Item
)) /= N_Selected_Component
2817 and then Entity
(Name
(Item
)) = Pack
2821 -- Find root library unit in with_clause
2823 while Nkind
(Par
) = N_Expanded_Name
loop
2824 Par
:= Prefix
(Par
);
2827 if Is_Child_Unit
(Entity
(Original_Node
(Par
))) then
2829 ("& is not directly visible", Par
, Entity
(Par
));
2838 -- On exit, package is not mentioned in a previous with_clause.
2839 -- Check if its prefix is.
2841 if Nkind
(Nam
) = N_Expanded_Name
then
2842 Check_In_Previous_With_Clause
(N
, Prefix
(Nam
));
2844 elsif Pack
/= Any_Id
then
2845 Error_Msg_NE
("& is not visible", Nam
, Pack
);
2847 end Check_In_Previous_With_Clause
;
2849 ---------------------------------
2850 -- Check_Library_Unit_Renaming --
2851 ---------------------------------
2853 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
) is
2857 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
2860 -- Check for library unit. Note that we used to check for the scope
2861 -- being Standard here, but that was wrong for Standard itself.
2863 elsif not Is_Compilation_Unit
(Old_E
)
2864 and then not Is_Child_Unit
(Old_E
)
2866 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
2868 -- Entities defined in Standard (operators and boolean literals) cannot
2869 -- be renamed as library units.
2871 elsif Scope
(Old_E
) = Standard_Standard
2872 and then Sloc
(Old_E
) = Standard_Location
2874 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
2876 elsif Present
(Parent_Spec
(N
))
2877 and then Nkind
(Unit
(Parent_Spec
(N
))) = N_Generic_Package_Declaration
2878 and then not Is_Child_Unit
(Old_E
)
2881 ("renamed unit must be a child unit of generic parent", Name
(N
));
2883 elsif Nkind
(N
) in N_Generic_Renaming_Declaration
2884 and then Nkind
(Name
(N
)) = N_Expanded_Name
2885 and then Is_Generic_Instance
(Entity
(Prefix
(Name
(N
))))
2886 and then Is_Generic_Unit
(Old_E
)
2889 ("renamed generic unit must be a library unit", Name
(N
));
2891 elsif Ekind
(Old_E
) = E_Package
2892 or else Ekind
(Old_E
) = E_Generic_Package
2894 -- Inherit categorization flags
2896 New_E
:= Defining_Entity
(N
);
2897 Set_Is_Pure
(New_E
, Is_Pure
(Old_E
));
2898 Set_Is_Preelaborated
(New_E
, Is_Preelaborated
(Old_E
));
2899 Set_Is_Remote_Call_Interface
(New_E
,
2900 Is_Remote_Call_Interface
(Old_E
));
2901 Set_Is_Remote_Types
(New_E
, Is_Remote_Types
(Old_E
));
2902 Set_Is_Shared_Passive
(New_E
, Is_Shared_Passive
(Old_E
));
2904 end Check_Library_Unit_Renaming
;
2910 procedure End_Scope
is
2916 Id
:= First_Entity
(Current_Scope
);
2917 while Present
(Id
) loop
2918 -- An entity in the current scope is not necessarily the first one
2919 -- on its homonym chain. Find its predecessor if any,
2920 -- If it is an internal entity, it will not be in the visibility
2921 -- chain altogether, and there is nothing to unchain.
2923 if Id
/= Current_Entity
(Id
) then
2924 Prev
:= Current_Entity
(Id
);
2925 while Present
(Prev
)
2926 and then Present
(Homonym
(Prev
))
2927 and then Homonym
(Prev
) /= Id
2929 Prev
:= Homonym
(Prev
);
2932 -- Skip to end of loop if Id is not in the visibility chain
2934 if No
(Prev
) or else Homonym
(Prev
) /= Id
then
2942 Set_Is_Immediately_Visible
(Id
, False);
2944 Outer
:= Homonym
(Id
);
2945 while Present
(Outer
) and then Scope
(Outer
) = Current_Scope
loop
2946 Outer
:= Homonym
(Outer
);
2949 -- Reset homonym link of other entities, but do not modify link
2950 -- between entities in current scope, so that the back-end can have
2951 -- a proper count of local overloadings.
2954 Set_Name_Entity_Id
(Chars
(Id
), Outer
);
2956 elsif Scope
(Prev
) /= Scope
(Id
) then
2957 Set_Homonym
(Prev
, Outer
);
2964 -- If the scope generated freeze actions, place them before the
2965 -- current declaration and analyze them. Type declarations and
2966 -- the bodies of initialization procedures can generate such nodes.
2967 -- We follow the parent chain until we reach a list node, which is
2968 -- the enclosing list of declarations. If the list appears within
2969 -- a protected definition, move freeze nodes outside the protected
2973 (Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
)
2977 L
: constant List_Id
:= Scope_Stack
.Table
2978 (Scope_Stack
.Last
).Pending_Freeze_Actions
;
2981 if Is_Itype
(Current_Scope
) then
2982 Decl
:= Associated_Node_For_Itype
(Current_Scope
);
2984 Decl
:= Parent
(Current_Scope
);
2989 while not (Is_List_Member
(Decl
))
2990 or else Nkind_In
(Parent
(Decl
), N_Protected_Definition
,
2993 Decl
:= Parent
(Decl
);
2996 Insert_List_Before_And_Analyze
(Decl
, L
);
3005 ---------------------
3006 -- End_Use_Clauses --
3007 ---------------------
3009 procedure End_Use_Clauses
(Clause
: Node_Id
) is
3013 -- Remove Use_Type clauses first, because they affect the
3014 -- visibility of operators in subsequent used packages.
3017 while Present
(U
) loop
3018 if Nkind
(U
) = N_Use_Type_Clause
then
3022 Next_Use_Clause
(U
);
3026 while Present
(U
) loop
3027 if Nkind
(U
) = N_Use_Package_Clause
then
3028 End_Use_Package
(U
);
3031 Next_Use_Clause
(U
);
3033 end End_Use_Clauses
;
3035 ---------------------
3036 -- End_Use_Package --
3037 ---------------------
3039 procedure End_Use_Package
(N
: Node_Id
) is
3040 Pack_Name
: Node_Id
;
3045 function Is_Primitive_Operator
3047 F
: Entity_Id
) return Boolean;
3048 -- Check whether Op is a primitive operator of a use-visible type
3050 ---------------------------
3051 -- Is_Primitive_Operator --
3052 ---------------------------
3054 function Is_Primitive_Operator
3056 F
: Entity_Id
) return Boolean
3058 T
: constant Entity_Id
:= Etype
(F
);
3061 and then Scope
(T
) = Scope
(Op
);
3062 end Is_Primitive_Operator
;
3064 -- Start of processing for End_Use_Package
3067 Pack_Name
:= First
(Names
(N
));
3068 while Present
(Pack_Name
) loop
3069 Pack
:= Entity
(Pack_Name
);
3071 if Ekind
(Pack
) = E_Package
then
3072 if In_Open_Scopes
(Pack
) then
3075 elsif not Redundant_Use
(Pack_Name
) then
3076 Set_In_Use
(Pack
, False);
3077 Set_Current_Use_Clause
(Pack
, Empty
);
3079 Id
:= First_Entity
(Pack
);
3080 while Present
(Id
) loop
3082 -- Preserve use-visibility of operators that are primitive
3083 -- operators of a type that is use-visible through an active
3086 if Nkind
(Id
) = N_Defining_Operator_Symbol
3088 (Is_Primitive_Operator
(Id
, First_Formal
(Id
))
3090 (Present
(Next_Formal
(First_Formal
(Id
)))
3092 Is_Primitive_Operator
3093 (Id
, Next_Formal
(First_Formal
(Id
)))))
3098 Set_Is_Potentially_Use_Visible
(Id
, False);
3101 if Is_Private_Type
(Id
)
3102 and then Present
(Full_View
(Id
))
3104 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
3110 if Present
(Renamed_Object
(Pack
)) then
3111 Set_In_Use
(Renamed_Object
(Pack
), False);
3112 Set_Current_Use_Clause
(Renamed_Object
(Pack
), Empty
);
3115 if Chars
(Pack
) = Name_System
3116 and then Scope
(Pack
) = Standard_Standard
3117 and then Present_System_Aux
3119 Id
:= First_Entity
(System_Aux_Id
);
3120 while Present
(Id
) loop
3121 Set_Is_Potentially_Use_Visible
(Id
, False);
3123 if Is_Private_Type
(Id
)
3124 and then Present
(Full_View
(Id
))
3126 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
3132 Set_In_Use
(System_Aux_Id
, False);
3136 Set_Redundant_Use
(Pack_Name
, False);
3143 if Present
(Hidden_By_Use_Clause
(N
)) then
3144 Elmt
:= First_Elmt
(Hidden_By_Use_Clause
(N
));
3145 while Present
(Elmt
) loop
3146 Set_Is_Immediately_Visible
(Node
(Elmt
));
3150 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
3152 end End_Use_Package
;
3158 procedure End_Use_Type
(N
: Node_Id
) is
3165 Id
:= First
(Subtype_Marks
(N
));
3166 while Present
(Id
) loop
3168 -- A call to rtsfind may occur while analyzing a use_type clause,
3169 -- in which case the type marks are not resolved yet, and there is
3170 -- nothing to remove.
3172 if not Is_Entity_Name
(Id
)
3173 or else No
(Entity
(Id
))
3181 or else From_With_Type
(T
)
3185 -- Note that the use_Type clause may mention a subtype of the type
3186 -- whose primitive operations have been made visible. Here as
3187 -- elsewhere, it is the base type that matters for visibility.
3189 elsif In_Open_Scopes
(Scope
(Base_Type
(T
))) then
3192 elsif not Redundant_Use
(Id
) then
3193 Set_In_Use
(T
, False);
3194 Set_In_Use
(Base_Type
(T
), False);
3195 Op_List
:= Collect_Primitive_Operations
(T
);
3197 Elmt
:= First_Elmt
(Op_List
);
3198 while Present
(Elmt
) loop
3199 if Nkind
(Node
(Elmt
)) = N_Defining_Operator_Symbol
then
3200 Set_Is_Potentially_Use_Visible
(Node
(Elmt
), False);
3212 ----------------------
3213 -- Find_Direct_Name --
3214 ----------------------
3216 procedure Find_Direct_Name
(N
: Node_Id
) is
3221 Inst
: Entity_Id
:= Empty
;
3222 -- Enclosing instance, if any
3224 Homonyms
: Entity_Id
;
3225 -- Saves start of homonym chain
3227 Nvis_Entity
: Boolean;
3228 -- Set True to indicate that at there is at least one entity on the
3229 -- homonym chain which, while not visible, is visible enough from the
3230 -- user point of view to warrant an error message of "not visible"
3231 -- rather than undefined.
3233 Nvis_Is_Private_Subprg
: Boolean := False;
3234 -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais
3235 -- effect concerning library subprograms has been detected. Used to
3236 -- generate the precise error message.
3238 function From_Actual_Package
(E
: Entity_Id
) return Boolean;
3239 -- Returns true if the entity is declared in a package that is
3240 -- an actual for a formal package of the current instance. Such an
3241 -- entity requires special handling because it may be use-visible
3242 -- but hides directly visible entities defined outside the instance.
3244 function Is_Actual_Parameter
return Boolean;
3245 -- This function checks if the node N is an identifier that is an actual
3246 -- parameter of a procedure call. If so it returns True, otherwise it
3247 -- return False. The reason for this check is that at this stage we do
3248 -- not know what procedure is being called if the procedure might be
3249 -- overloaded, so it is premature to go setting referenced flags or
3250 -- making calls to Generate_Reference. We will wait till Resolve_Actuals
3251 -- for that processing
3253 function Known_But_Invisible
(E
: Entity_Id
) return Boolean;
3254 -- This function determines whether the entity E (which is not
3255 -- visible) can reasonably be considered to be known to the writer
3256 -- of the reference. This is a heuristic test, used only for the
3257 -- purposes of figuring out whether we prefer to complain that an
3258 -- entity is undefined or invisible (and identify the declaration
3259 -- of the invisible entity in the latter case). The point here is
3260 -- that we don't want to complain that something is invisible and
3261 -- then point to something entirely mysterious to the writer.
3263 procedure Nvis_Messages
;
3264 -- Called if there are no visible entries for N, but there is at least
3265 -- one non-directly visible, or hidden declaration. This procedure
3266 -- outputs an appropriate set of error messages.
3268 procedure Undefined
(Nvis
: Boolean);
3269 -- This function is called if the current node has no corresponding
3270 -- visible entity or entities. The value set in Msg indicates whether
3271 -- an error message was generated (multiple error messages for the
3272 -- same variable are generally suppressed, see body for details).
3273 -- Msg is True if an error message was generated, False if not. This
3274 -- value is used by the caller to determine whether or not to output
3275 -- additional messages where appropriate. The parameter is set False
3276 -- to get the message "X is undefined", and True to get the message
3277 -- "X is not visible".
3279 -------------------------
3280 -- From_Actual_Package --
3281 -------------------------
3283 function From_Actual_Package
(E
: Entity_Id
) return Boolean is
3284 Scop
: constant Entity_Id
:= Scope
(E
);
3288 if not In_Instance
then
3291 Inst
:= Current_Scope
;
3292 while Present
(Inst
)
3293 and then Ekind
(Inst
) /= E_Package
3294 and then not Is_Generic_Instance
(Inst
)
3296 Inst
:= Scope
(Inst
);
3303 Act
:= First_Entity
(Inst
);
3304 while Present
(Act
) loop
3305 if Ekind
(Act
) = E_Package
then
3307 -- Check for end of actuals list
3309 if Renamed_Object
(Act
) = Inst
then
3312 elsif Present
(Associated_Formal_Package
(Act
))
3313 and then Renamed_Object
(Act
) = Scop
3315 -- Entity comes from (instance of) formal package
3330 end From_Actual_Package
;
3332 -------------------------
3333 -- Is_Actual_Parameter --
3334 -------------------------
3336 function Is_Actual_Parameter
return Boolean is
3339 Nkind
(N
) = N_Identifier
3341 (Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
3343 (Nkind
(Parent
(N
)) = N_Parameter_Association
3344 and then N
= Explicit_Actual_Parameter
(Parent
(N
))
3345 and then Nkind
(Parent
(Parent
(N
))) =
3346 N_Procedure_Call_Statement
));
3347 end Is_Actual_Parameter
;
3349 -------------------------
3350 -- Known_But_Invisible --
3351 -------------------------
3353 function Known_But_Invisible
(E
: Entity_Id
) return Boolean is
3354 Fname
: File_Name_Type
;
3357 -- Entities in Standard are always considered to be known
3359 if Sloc
(E
) <= Standard_Location
then
3362 -- An entity that does not come from source is always considered
3363 -- to be unknown, since it is an artifact of code expansion.
3365 elsif not Comes_From_Source
(E
) then
3368 -- In gnat internal mode, we consider all entities known
3370 elsif GNAT_Mode
then
3374 -- Here we have an entity that is not from package Standard, and
3375 -- which comes from Source. See if it comes from an internal file.
3377 Fname
:= Unit_File_Name
(Get_Source_Unit
(E
));
3379 -- Case of from internal file
3381 if Is_Internal_File_Name
(Fname
) then
3383 -- Private part entities in internal files are never considered
3384 -- to be known to the writer of normal application code.
3386 if Is_Hidden
(E
) then
3390 -- Entities from System packages other than System and
3391 -- System.Storage_Elements are not considered to be known.
3392 -- System.Auxxxx files are also considered known to the user.
3394 -- Should refine this at some point to generally distinguish
3395 -- between known and unknown internal files ???
3397 Get_Name_String
(Fname
);
3402 Name_Buffer
(1 .. 2) /= "s-"
3404 Name_Buffer
(3 .. 8) = "stoele"
3406 Name_Buffer
(3 .. 5) = "aux";
3408 -- If not an internal file, then entity is definitely known,
3409 -- even if it is in a private part (the message generated will
3410 -- note that it is in a private part)
3415 end Known_But_Invisible
;
3421 procedure Nvis_Messages
is
3422 Comp_Unit
: Node_Id
;
3424 Hidden
: Boolean := False;
3428 -- Ada 2005 (AI-262): Generate a precise error concerning the
3429 -- Beaujolais effect that was previously detected
3431 if Nvis_Is_Private_Subprg
then
3433 pragma Assert
(Nkind
(E2
) = N_Defining_Identifier
3434 and then Ekind
(E2
) = E_Function
3435 and then Scope
(E2
) = Standard_Standard
3436 and then Has_Private_With
(E2
));
3438 -- Find the sloc corresponding to the private with'ed unit
3440 Comp_Unit
:= Cunit
(Current_Sem_Unit
);
3441 Error_Msg_Sloc
:= No_Location
;
3443 Item
:= First
(Context_Items
(Comp_Unit
));
3444 while Present
(Item
) loop
3445 if Nkind
(Item
) = N_With_Clause
3446 and then Private_Present
(Item
)
3447 and then Entity
(Name
(Item
)) = E2
3449 Error_Msg_Sloc
:= Sloc
(Item
);
3456 pragma Assert
(Error_Msg_Sloc
/= No_Location
);
3458 Error_Msg_N
("(Ada 2005): hidden by private with clause #", N
);
3462 Undefined
(Nvis
=> True);
3466 -- First loop does hidden declarations
3469 while Present
(Ent
) loop
3470 if Is_Potentially_Use_Visible
(Ent
) then
3472 Error_Msg_N
("multiple use clauses cause hiding!", N
);
3476 Error_Msg_Sloc
:= Sloc
(Ent
);
3477 Error_Msg_N
("hidden declaration#!", N
);
3480 Ent
:= Homonym
(Ent
);
3483 -- If we found hidden declarations, then that's enough, don't
3484 -- bother looking for non-visible declarations as well.
3490 -- Second loop does non-directly visible declarations
3493 while Present
(Ent
) loop
3494 if not Is_Potentially_Use_Visible
(Ent
) then
3496 -- Do not bother the user with unknown entities
3498 if not Known_But_Invisible
(Ent
) then
3502 Error_Msg_Sloc
:= Sloc
(Ent
);
3504 -- Output message noting that there is a non-visible
3505 -- declaration, distinguishing the private part case.
3507 if Is_Hidden
(Ent
) then
3508 Error_Msg_N
("non-visible (private) declaration#!", N
);
3510 Error_Msg_N
("non-visible declaration#!", N
);
3512 if Is_Compilation_Unit
(Ent
)
3514 Nkind
(Parent
(Parent
(N
))) = N_Use_Package_Clause
3516 Error_Msg_Qual_Level
:= 99;
3517 Error_Msg_NE
("\\missing `WITH &;`", N
, Ent
);
3518 Error_Msg_Qual_Level
:= 0;
3522 -- Set entity and its containing package as referenced. We
3523 -- can't be sure of this, but this seems a better choice
3524 -- to avoid unused entity messages.
3526 if Comes_From_Source
(Ent
) then
3527 Set_Referenced
(Ent
);
3528 Set_Referenced
(Cunit_Entity
(Get_Source_Unit
(Ent
)));
3533 Ent
:= Homonym
(Ent
);
3542 procedure Undefined
(Nvis
: Boolean) is
3543 Emsg
: Error_Msg_Id
;
3546 -- We should never find an undefined internal name. If we do, then
3547 -- see if we have previous errors. If so, ignore on the grounds that
3548 -- it is probably a cascaded message (e.g. a block label from a badly
3549 -- formed block). If no previous errors, then we have a real internal
3550 -- error of some kind so raise an exception.
3552 if Is_Internal_Name
(Chars
(N
)) then
3553 if Total_Errors_Detected
/= 0 then
3556 raise Program_Error
;
3560 -- A very specialized error check, if the undefined variable is
3561 -- a case tag, and the case type is an enumeration type, check
3562 -- for a possible misspelling, and if so, modify the identifier
3564 -- Named aggregate should also be handled similarly ???
3566 if Nkind
(N
) = N_Identifier
3567 and then Nkind
(Parent
(N
)) = N_Case_Statement_Alternative
3570 Case_Stm
: constant Node_Id
:= Parent
(Parent
(N
));
3571 Case_Typ
: constant Entity_Id
:= Etype
(Expression
(Case_Stm
));
3572 Case_Rtp
: constant Entity_Id
:= Root_Type
(Case_Typ
);
3577 if Is_Enumeration_Type
(Case_Typ
)
3578 and then Case_Rtp
/= Standard_Character
3579 and then Case_Rtp
/= Standard_Wide_Character
3580 and then Case_Rtp
/= Standard_Wide_Wide_Character
3582 Lit
:= First_Literal
(Case_Typ
);
3583 Get_Name_String
(Chars
(Lit
));
3585 if Chars
(Lit
) /= Chars
(N
)
3586 and then Is_Bad_Spelling_Of
(Chars
(N
), Chars
(Lit
)) then
3587 Error_Msg_Node_2
:= Lit
;
3589 ("& is undefined, assume misspelling of &", N
);
3590 Rewrite
(N
, New_Occurrence_Of
(Lit
, Sloc
(N
)));
3594 Lit
:= Next_Literal
(Lit
);
3599 -- Normal processing
3601 Set_Entity
(N
, Any_Id
);
3602 Set_Etype
(N
, Any_Type
);
3604 -- We use the table Urefs to keep track of entities for which we
3605 -- have issued errors for undefined references. Multiple errors
3606 -- for a single name are normally suppressed, however we modify
3607 -- the error message to alert the programmer to this effect.
3609 for J
in Urefs
.First
.. Urefs
.Last
loop
3610 if Chars
(N
) = Chars
(Urefs
.Table
(J
).Node
) then
3611 if Urefs
.Table
(J
).Err
/= No_Error_Msg
3612 and then Sloc
(N
) /= Urefs
.Table
(J
).Loc
3614 Error_Msg_Node_1
:= Urefs
.Table
(J
).Node
;
3616 if Urefs
.Table
(J
).Nvis
then
3617 Change_Error_Text
(Urefs
.Table
(J
).Err
,
3618 "& is not visible (more references follow)");
3620 Change_Error_Text
(Urefs
.Table
(J
).Err
,
3621 "& is undefined (more references follow)");
3624 Urefs
.Table
(J
).Err
:= No_Error_Msg
;
3627 -- Although we will set Msg False, and thus suppress the
3628 -- message, we also set Error_Posted True, to avoid any
3629 -- cascaded messages resulting from the undefined reference.
3632 Set_Error_Posted
(N
, True);
3637 -- If entry not found, this is first undefined occurrence
3640 Error_Msg_N
("& is not visible!", N
);
3644 Error_Msg_N
("& is undefined!", N
);
3647 -- A very bizarre special check, if the undefined identifier
3648 -- is put or put_line, then add a special error message (since
3649 -- this is a very common error for beginners to make).
3651 if Chars
(N
) = Name_Put
or else Chars
(N
) = Name_Put_Line
then
3653 ("\\possible missing `WITH Ada.Text_'I'O; " &
3654 "USE Ada.Text_'I'O`!", N
);
3656 -- Another special check if N is the prefix of a selected
3657 -- component which is a known unit, add message complaining
3658 -- about missing with for this unit.
3660 elsif Nkind
(Parent
(N
)) = N_Selected_Component
3661 and then N
= Prefix
(Parent
(N
))
3662 and then Is_Known_Unit
(Parent
(N
))
3664 Error_Msg_Node_2
:= Selector_Name
(Parent
(N
));
3665 Error_Msg_N
("\\missing `WITH &.&;`", Prefix
(Parent
(N
)));
3668 -- Now check for possible misspellings
3672 Ematch
: Entity_Id
:= Empty
;
3674 Last_Name_Id
: constant Name_Id
:=
3675 Name_Id
(Nat
(First_Name_Id
) +
3676 Name_Entries_Count
- 1);
3679 for Nam
in First_Name_Id
.. Last_Name_Id
loop
3680 E
:= Get_Name_Entity_Id
(Nam
);
3683 and then (Is_Immediately_Visible
(E
)
3685 Is_Potentially_Use_Visible
(E
))
3687 if Is_Bad_Spelling_Of
(Chars
(N
), Nam
) then
3694 if Present
(Ematch
) then
3695 Error_Msg_NE
("\possible misspelling of&", N
, Ematch
);
3700 -- Make entry in undefined references table unless the full errors
3701 -- switch is set, in which case by refraining from generating the
3702 -- table entry, we guarantee that we get an error message for every
3703 -- undefined reference.
3705 if not All_Errors_Mode
then
3716 -- Start of processing for Find_Direct_Name
3719 -- If the entity pointer is already set, this is an internal node, or
3720 -- a node that is analyzed more than once, after a tree modification.
3721 -- In such a case there is no resolution to perform, just set the type.
3723 if Present
(Entity
(N
)) then
3724 if Is_Type
(Entity
(N
)) then
3725 Set_Etype
(N
, Entity
(N
));
3729 Entyp
: constant Entity_Id
:= Etype
(Entity
(N
));
3732 -- One special case here. If the Etype field is already set,
3733 -- and references the packed array type corresponding to the
3734 -- etype of the referenced entity, then leave it alone. This
3735 -- happens for trees generated from Exp_Pakd, where expressions
3736 -- can be deliberately "mis-typed" to the packed array type.
3738 if Is_Array_Type
(Entyp
)
3739 and then Is_Packed
(Entyp
)
3740 and then Present
(Etype
(N
))
3741 and then Etype
(N
) = Packed_Array_Type
(Entyp
)
3745 -- If not that special case, then just reset the Etype
3748 Set_Etype
(N
, Etype
(Entity
(N
)));
3756 -- Here if Entity pointer was not set, we need full visibility analysis
3757 -- First we generate debugging output if the debug E flag is set.
3759 if Debug_Flag_E
then
3760 Write_Str
("Looking for ");
3761 Write_Name
(Chars
(N
));
3765 Homonyms
:= Current_Entity
(N
);
3766 Nvis_Entity
:= False;
3769 while Present
(E
) loop
3771 -- If entity is immediately visible or potentially use
3772 -- visible, then process the entity and we are done.
3774 if Is_Immediately_Visible
(E
) then
3775 goto Immediately_Visible_Entity
;
3777 elsif Is_Potentially_Use_Visible
(E
) then
3778 goto Potentially_Use_Visible_Entity
;
3780 -- Note if a known but invisible entity encountered
3782 elsif Known_But_Invisible
(E
) then
3783 Nvis_Entity
:= True;
3786 -- Move to next entity in chain and continue search
3791 -- If no entries on homonym chain that were potentially visible,
3792 -- and no entities reasonably considered as non-visible, then
3793 -- we have a plain undefined reference, with no additional
3794 -- explanation required!
3796 if not Nvis_Entity
then
3797 Undefined
(Nvis
=> False);
3799 -- Otherwise there is at least one entry on the homonym chain that
3800 -- is reasonably considered as being known and non-visible.
3808 -- Processing for a potentially use visible entry found. We must search
3809 -- the rest of the homonym chain for two reasons. First, if there is a
3810 -- directly visible entry, then none of the potentially use-visible
3811 -- entities are directly visible (RM 8.4(10)). Second, we need to check
3812 -- for the case of multiple potentially use-visible entries hiding one
3813 -- another and as a result being non-directly visible (RM 8.4(11)).
3815 <<Potentially_Use_Visible_Entity
>> declare
3816 Only_One_Visible
: Boolean := True;
3817 All_Overloadable
: Boolean := Is_Overloadable
(E
);
3821 while Present
(E2
) loop
3822 if Is_Immediately_Visible
(E2
) then
3824 -- If the use-visible entity comes from the actual for a
3825 -- formal package, it hides a directly visible entity from
3826 -- outside the instance.
3828 if From_Actual_Package
(E
)
3829 and then Scope_Depth
(E2
) < Scope_Depth
(Inst
)
3834 goto Immediately_Visible_Entity
;
3837 elsif Is_Potentially_Use_Visible
(E2
) then
3838 Only_One_Visible
:= False;
3839 All_Overloadable
:= All_Overloadable
and Is_Overloadable
(E2
);
3841 -- Ada 2005 (AI-262): Protect against a form of Beujolais effect
3842 -- that can occurr in private_with clauses. Example:
3845 -- private with B; package A is
3846 -- package C is function B return Integer;
3848 -- V1 : Integer := B;
3849 -- private function B return Integer;
3850 -- V2 : Integer := B;
3853 -- V1 resolves to A.B, but V2 resolves to library unit B
3855 elsif Ekind
(E2
) = E_Function
3856 and then Scope
(E2
) = Standard_Standard
3857 and then Has_Private_With
(E2
)
3859 Only_One_Visible
:= False;
3860 All_Overloadable
:= False;
3861 Nvis_Is_Private_Subprg
:= True;
3868 -- On falling through this loop, we have checked that there are no
3869 -- immediately visible entities. Only_One_Visible is set if exactly
3870 -- one potentially use visible entity exists. All_Overloadable is
3871 -- set if all the potentially use visible entities are overloadable.
3872 -- The condition for legality is that either there is one potentially
3873 -- use visible entity, or if there is more than one, then all of them
3874 -- are overloadable.
3876 if Only_One_Visible
or All_Overloadable
then
3879 -- If there is more than one potentially use-visible entity and at
3880 -- least one of them non-overloadable, we have an error (RM 8.4(11).
3881 -- Note that E points to the first such entity on the homonym list.
3882 -- Special case: if one of the entities is declared in an actual
3883 -- package, it was visible in the generic, and takes precedence over
3884 -- other entities that are potentially use-visible. Same if it is
3885 -- declared in a local instantiation of the current instance.
3890 -- Find current instance
3892 Inst
:= Current_Scope
;
3893 while Present
(Inst
)
3894 and then Inst
/= Standard_Standard
3896 if Is_Generic_Instance
(Inst
) then
3900 Inst
:= Scope
(Inst
);
3904 while Present
(E2
) loop
3905 if From_Actual_Package
(E2
)
3907 (Is_Generic_Instance
(Scope
(E2
))
3908 and then Scope_Depth
(Scope
(E2
)) > Scope_Depth
(Inst
))
3921 Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
3923 -- A use-clause in the body of a system file creates conflict
3924 -- with some entity in a user scope, while rtsfind is active.
3925 -- Keep only the entity coming from another predefined unit.
3928 while Present
(E2
) loop
3929 if Is_Predefined_File_Name
3930 (Unit_File_Name
(Get_Source_Unit
(Sloc
(E2
))))
3939 -- Entity must exist because predefined unit is correct
3941 raise Program_Error
;
3950 -- Come here with E set to the first immediately visible entity on
3951 -- the homonym chain. This is the one we want unless there is another
3952 -- immediately visible entity further on in the chain for a more
3953 -- inner scope (RM 8.3(8)).
3955 <<Immediately_Visible_Entity
>> declare
3960 -- Find scope level of initial entity. When compiling through
3961 -- Rtsfind, the previous context is not completely invisible, and
3962 -- an outer entity may appear on the chain, whose scope is below
3963 -- the entry for Standard that delimits the current scope stack.
3964 -- Indicate that the level for this spurious entry is outside of
3965 -- the current scope stack.
3967 Level
:= Scope_Stack
.Last
;
3969 Scop
:= Scope_Stack
.Table
(Level
).Entity
;
3970 exit when Scop
= Scope
(E
);
3972 exit when Scop
= Standard_Standard
;
3975 -- Now search remainder of homonym chain for more inner entry
3976 -- If the entity is Standard itself, it has no scope, and we
3977 -- compare it with the stack entry directly.
3980 while Present
(E2
) loop
3981 if Is_Immediately_Visible
(E2
) then
3983 -- If a generic package contains a local declaration that
3984 -- has the same name as the generic, there may be a visibility
3985 -- conflict in an instance, where the local declaration must
3986 -- also hide the name of the corresponding package renaming.
3987 -- We check explicitly for a package declared by a renaming,
3988 -- whose renamed entity is an instance that is on the scope
3989 -- stack, and that contains a homonym in the same scope. Once
3990 -- we have found it, we know that the package renaming is not
3991 -- immediately visible, and that the identifier denotes the
3992 -- other entity (and its homonyms if overloaded).
3994 if Scope
(E
) = Scope
(E2
)
3995 and then Ekind
(E
) = E_Package
3996 and then Present
(Renamed_Object
(E
))
3997 and then Is_Generic_Instance
(Renamed_Object
(E
))
3998 and then In_Open_Scopes
(Renamed_Object
(E
))
3999 and then Comes_From_Source
(N
)
4001 Set_Is_Immediately_Visible
(E
, False);
4005 for J
in Level
+ 1 .. Scope_Stack
.Last
loop
4006 if Scope_Stack
.Table
(J
).Entity
= Scope
(E2
)
4007 or else Scope_Stack
.Table
(J
).Entity
= E2
4020 -- At the end of that loop, E is the innermost immediately
4021 -- visible entity, so we are all set.
4024 -- Come here with entity found, and stored in E
4028 -- When distribution features are available (Get_PCS_Name /=
4029 -- Name_No_DSA), a remote access-to-subprogram type is converted
4030 -- into a record type holding whatever information is needed to
4031 -- perform a remote call on an RCI suprogram. In that case we
4032 -- rewrite any occurrence of the RAS type into the equivalent record
4033 -- type here. 'Access attribute references and RAS dereferences are
4034 -- then implemented using specific TSSs. However when distribution is
4035 -- not available (case of Get_PCS_Name = Name_No_DSA), we bypass the
4036 -- generation of these TSSs, and we must keep the RAS type in its
4037 -- original access-to-subprogram form (since all calls through a
4038 -- value of such type will be local anyway in the absence of a PCS).
4040 if Comes_From_Source
(N
)
4041 and then Is_Remote_Access_To_Subprogram_Type
(E
)
4042 and then Expander_Active
4043 and then Get_PCS_Name
/= Name_No_DSA
4046 New_Occurrence_Of
(Equivalent_Type
(E
), Sloc
(N
)));
4051 -- Why no Style_Check here???
4056 Set_Etype
(N
, Get_Full_View
(Etype
(E
)));
4059 if Debug_Flag_E
then
4060 Write_Str
(" found ");
4061 Write_Entity_Info
(E
, " ");
4064 -- If the Ekind of the entity is Void, it means that all homonyms
4065 -- are hidden from all visibility (RM 8.3(5,14-20)). However, this
4066 -- test is skipped if the current scope is a record and the name is
4067 -- a pragma argument expression (case of Atomic and Volatile pragmas
4068 -- and possibly other similar pragmas added later, which are allowed
4069 -- to reference components in the current record).
4071 if Ekind
(E
) = E_Void
4073 (not Is_Record_Type
(Current_Scope
)
4074 or else Nkind
(Parent
(N
)) /= N_Pragma_Argument_Association
)
4076 Premature_Usage
(N
);
4078 -- If the entity is overloadable, collect all interpretations of the
4079 -- name for subsequent overload resolution. We optimize a bit here to
4080 -- do this only if we have an overloadable entity that is not on its
4081 -- own on the homonym chain.
4083 elsif Is_Overloadable
(E
)
4084 and then (Present
(Homonym
(E
)) or else Current_Entity
(N
) /= E
)
4086 Collect_Interps
(N
);
4088 -- If no homonyms were visible, the entity is unambiguous
4090 if not Is_Overloaded
(N
) then
4091 if not Is_Actual_Parameter
then
4092 Generate_Reference
(E
, N
);
4096 -- Case of non-overloadable entity, set the entity providing that
4097 -- we do not have the case of a discriminant reference within a
4098 -- default expression. Such references are replaced with the
4099 -- corresponding discriminal, which is the formal corresponding to
4100 -- to the discriminant in the initialization procedure.
4103 -- Entity is unambiguous, indicate that it is referenced here
4105 -- For a renaming of an object, always generate simple reference,
4106 -- we don't try to keep track of assignments in this case.
4108 if Is_Object
(E
) and then Present
(Renamed_Object
(E
)) then
4109 Generate_Reference
(E
, N
);
4111 -- One odd case is that we do not want to set the Referenced flag
4112 -- if the entity is a label, and the identifier is the label in
4113 -- the source, since this is not a reference from the point of
4114 -- view of the user.
4116 elsif Nkind
(Parent
(N
)) = N_Label
then
4118 R
: constant Boolean := Referenced
(E
);
4121 -- Generate reference unless this is an actual parameter
4122 -- (see comment below)
4124 if Is_Actual_Parameter
then
4125 Generate_Reference
(E
, N
);
4126 Set_Referenced
(E
, R
);
4130 -- Normal case, not a label: generate reference
4132 -- ??? It is too early to generate a reference here even if
4133 -- the entity is unambiguous, because the tree is not
4134 -- sufficiently typed at this point for Generate_Reference to
4135 -- determine whether this reference modifies the denoted object
4136 -- (because implicit derefences cannot be identified prior to
4137 -- full type resolution).
4139 -- ??? The Is_Actual_Parameter routine takes care of one of these
4140 -- cases but there are others probably
4143 if not Is_Actual_Parameter
then
4144 Generate_Reference
(E
, N
);
4147 Check_Nested_Access
(E
);
4150 -- Set Entity, with style check if need be. For a discriminant
4151 -- reference, replace by the corresponding discriminal, i.e. the
4152 -- parameter of the initialization procedure that corresponds to
4153 -- the discriminant. If this replacement is being performed, there
4154 -- is no style check to perform.
4156 -- This replacement must not be done if we are currently
4157 -- processing a generic spec or body, because the discriminal
4158 -- has not been not generated in this case.
4160 if not In_Default_Expression
4161 or else Ekind
(E
) /= E_Discriminant
4162 or else Inside_A_Generic
4164 Set_Entity_With_Style_Check
(N
, E
);
4166 -- The replacement is not done either for a task discriminant that
4167 -- appears in a default expression of an entry parameter. See
4168 -- Expand_Discriminant in exp_ch2 for details on their handling.
4170 elsif Is_Concurrent_Type
(Scope
(E
)) then
4177 and then not Nkind_In
(P
, N_Parameter_Specification
,
4178 N_Component_Declaration
)
4184 and then Nkind
(P
) = N_Parameter_Specification
4188 Set_Entity
(N
, Discriminal
(E
));
4192 -- Otherwise, this is a discriminant in a context in which
4193 -- it is a reference to the corresponding parameter of the
4194 -- init proc for the enclosing type.
4197 Set_Entity
(N
, Discriminal
(E
));
4201 end Find_Direct_Name
;
4203 ------------------------
4204 -- Find_Expanded_Name --
4205 ------------------------
4207 -- This routine searches the homonym chain of the entity until it finds
4208 -- an entity declared in the scope denoted by the prefix. If the entity
4209 -- is private, it may nevertheless be immediately visible, if we are in
4210 -- the scope of its declaration.
4212 procedure Find_Expanded_Name
(N
: Node_Id
) is
4213 Selector
: constant Node_Id
:= Selector_Name
(N
);
4214 Candidate
: Entity_Id
:= Empty
;
4220 P_Name
:= Entity
(Prefix
(N
));
4223 -- If the prefix is a renamed package, look for the entity
4224 -- in the original package.
4226 if Ekind
(P_Name
) = E_Package
4227 and then Present
(Renamed_Object
(P_Name
))
4229 P_Name
:= Renamed_Object
(P_Name
);
4231 -- Rewrite node with entity field pointing to renamed object
4233 Rewrite
(Prefix
(N
), New_Copy
(Prefix
(N
)));
4234 Set_Entity
(Prefix
(N
), P_Name
);
4236 -- If the prefix is an object of a concurrent type, look for
4237 -- the entity in the associated task or protected type.
4239 elsif Is_Concurrent_Type
(Etype
(P_Name
)) then
4240 P_Name
:= Etype
(P_Name
);
4243 Id
:= Current_Entity
(Selector
);
4246 Is_New_Candidate
: Boolean;
4249 while Present
(Id
) loop
4250 if Scope
(Id
) = P_Name
then
4252 Is_New_Candidate
:= True;
4254 -- Ada 2005 (AI-217): Handle shadow entities associated with types
4255 -- declared in limited-withed nested packages. We don't need to
4256 -- handle E_Incomplete_Subtype entities because the entities in
4257 -- the limited view are always E_Incomplete_Type entities (see
4258 -- Build_Limited_Views). Regarding the expression used to evaluate
4259 -- the scope, it is important to note that the limited view also
4260 -- has shadow entities associated nested packages. For this reason
4261 -- the correct scope of the entity is the scope of the real entity
4262 -- The non-limited view may itself be incomplete, in which case
4263 -- get the full view if available.
4265 elsif From_With_Type
(Id
)
4266 and then Is_Type
(Id
)
4267 and then Ekind
(Id
) = E_Incomplete_Type
4268 and then Present
(Non_Limited_View
(Id
))
4269 and then Scope
(Non_Limited_View
(Id
)) = P_Name
4271 Candidate
:= Get_Full_View
(Non_Limited_View
(Id
));
4272 Is_New_Candidate
:= True;
4275 Is_New_Candidate
:= False;
4278 if Is_New_Candidate
then
4279 if Is_Child_Unit
(Id
) then
4280 exit when Is_Visible_Child_Unit
(Id
)
4281 or else Is_Immediately_Visible
(Id
);
4284 exit when not Is_Hidden
(Id
)
4285 or else Is_Immediately_Visible
(Id
);
4294 and then (Ekind
(P_Name
) = E_Procedure
4296 Ekind
(P_Name
) = E_Function
)
4297 and then Is_Generic_Instance
(P_Name
)
4299 -- Expanded name denotes entity in (instance of) generic subprogram.
4300 -- The entity may be in the subprogram instance, or may denote one of
4301 -- the formals, which is declared in the enclosing wrapper package.
4303 P_Name
:= Scope
(P_Name
);
4305 Id
:= Current_Entity
(Selector
);
4306 while Present
(Id
) loop
4307 exit when Scope
(Id
) = P_Name
;
4312 if No
(Id
) or else Chars
(Id
) /= Chars
(Selector
) then
4313 Set_Etype
(N
, Any_Type
);
4315 -- If we are looking for an entity defined in System, try to
4316 -- find it in the child package that may have been provided as
4317 -- an extension to System. The Extend_System pragma will have
4318 -- supplied the name of the extension, which may have to be loaded.
4320 if Chars
(P_Name
) = Name_System
4321 and then Scope
(P_Name
) = Standard_Standard
4322 and then Present
(System_Extend_Unit
)
4323 and then Present_System_Aux
(N
)
4325 Set_Entity
(Prefix
(N
), System_Aux_Id
);
4326 Find_Expanded_Name
(N
);
4329 elsif Nkind
(Selector
) = N_Operator_Symbol
4330 and then Has_Implicit_Operator
(N
)
4332 -- There is an implicit instance of the predefined operator in
4333 -- the given scope. The operator entity is defined in Standard.
4334 -- Has_Implicit_Operator makes the node into an Expanded_Name.
4338 elsif Nkind
(Selector
) = N_Character_Literal
4339 and then Has_Implicit_Character_Literal
(N
)
4341 -- If there is no literal defined in the scope denoted by the
4342 -- prefix, the literal may belong to (a type derived from)
4343 -- Standard_Character, for which we have no explicit literals.
4348 -- If the prefix is a single concurrent object, use its
4349 -- name in the error message, rather than that of the
4352 if Is_Concurrent_Type
(P_Name
)
4353 and then Is_Internal_Name
(Chars
(P_Name
))
4355 Error_Msg_Node_2
:= Entity
(Prefix
(N
));
4357 Error_Msg_Node_2
:= P_Name
;
4360 if P_Name
= System_Aux_Id
then
4361 P_Name
:= Scope
(P_Name
);
4362 Set_Entity
(Prefix
(N
), P_Name
);
4365 if Present
(Candidate
) then
4367 -- If we know that the unit is a child unit we can give a more
4368 -- accurate error message.
4370 if Is_Child_Unit
(Candidate
) then
4372 -- If the candidate is a private child unit and we are in
4373 -- the visible part of a public unit, specialize the error
4374 -- message. There might be a private with_clause for it,
4375 -- but it is not currently active.
4377 if Is_Private_Descendant
(Candidate
)
4378 and then Ekind
(Current_Scope
) = E_Package
4379 and then not In_Private_Part
(Current_Scope
)
4380 and then not Is_Private_Descendant
(Current_Scope
)
4382 Error_Msg_N
("private child unit& is not visible here",
4385 -- Normal case where we have a missing with for a child unit
4388 Error_Msg_Qual_Level
:= 99;
4389 Error_Msg_NE
("missing `WITH &;`", Selector
, Candidate
);
4390 Error_Msg_Qual_Level
:= 0;
4393 -- Here we don't know that this is a child unit
4396 Error_Msg_NE
("& is not a visible entity of&", N
, Selector
);
4400 -- Within the instantiation of a child unit, the prefix may
4401 -- denote the parent instance, but the selector has the name
4402 -- of the original child. Find whether we are within the
4403 -- corresponding instance, and get the proper entity, which
4404 -- can only be an enclosing scope.
4407 and then In_Open_Scopes
(P_Name
)
4408 and then Is_Generic_Instance
(P_Name
)
4411 S
: Entity_Id
:= Current_Scope
;
4415 for J
in reverse 0 .. Scope_Stack
.Last
loop
4416 S
:= Scope_Stack
.Table
(J
).Entity
;
4418 exit when S
= Standard_Standard
;
4420 if Ekind
(S
) = E_Function
4421 or else Ekind
(S
) = E_Package
4422 or else Ekind
(S
) = E_Procedure
4424 P
:= Generic_Parent
(Specification
4425 (Unit_Declaration_Node
(S
)));
4428 and then Chars
(Scope
(P
)) = Chars
(O_Name
)
4429 and then Chars
(P
) = Chars
(Selector
)
4440 -- If this is a selection from Ada, System or Interfaces, then
4441 -- we assume a missing with for the corresponding package.
4443 if Is_Known_Unit
(N
) then
4444 if not Error_Posted
(N
) then
4445 Error_Msg_Node_2
:= Selector
;
4446 Error_Msg_N
("missing `WITH &.&;`", Prefix
(N
));
4449 -- If this is a selection from a dummy package, then suppress
4450 -- the error message, of course the entity is missing if the
4451 -- package is missing!
4453 elsif Sloc
(Error_Msg_Node_2
) = No_Location
then
4456 -- Here we have the case of an undefined component
4459 Error_Msg_NE
("& not declared in&", N
, Selector
);
4461 -- Check for misspelling of some entity in prefix
4463 Id
:= First_Entity
(P_Name
);
4464 while Present
(Id
) loop
4465 if Is_Bad_Spelling_Of
(Chars
(Id
), Chars
(Selector
))
4466 and then not Is_Internal_Name
(Chars
(Id
))
4469 ("possible misspelling of&", Selector
, Id
);
4476 -- Specialize the message if this may be an instantiation
4477 -- of a child unit that was not mentioned in the context.
4479 if Nkind
(Parent
(N
)) = N_Package_Instantiation
4480 and then Is_Generic_Instance
(Entity
(Prefix
(N
)))
4481 and then Is_Compilation_Unit
4482 (Generic_Parent
(Parent
(Entity
(Prefix
(N
)))))
4484 Error_Msg_Node_2
:= Selector
;
4485 Error_Msg_N
("\missing `WITH &.&;`", Prefix
(N
));
4495 if Comes_From_Source
(N
)
4496 and then Is_Remote_Access_To_Subprogram_Type
(Id
)
4497 and then Present
(Equivalent_Type
(Id
))
4499 -- If we are not actually generating distribution code (i.e. the
4500 -- current PCS is the dummy non-distributed version), then the
4501 -- Equivalent_Type will be missing, and Id should be treated as
4502 -- a regular access-to-subprogram type.
4504 Id
:= Equivalent_Type
(Id
);
4505 Set_Chars
(Selector
, Chars
(Id
));
4508 -- Ada 2005 (AI-50217): Check usage of entities in limited withed units
4510 if Ekind
(P_Name
) = E_Package
4511 and then From_With_Type
(P_Name
)
4513 if From_With_Type
(Id
)
4514 or else Is_Type
(Id
)
4515 or else Ekind
(Id
) = E_Package
4520 ("limited withed package can only be used to access "
4521 & " incomplete types",
4526 if Is_Task_Type
(P_Name
)
4527 and then ((Ekind
(Id
) = E_Entry
4528 and then Nkind
(Parent
(N
)) /= N_Attribute_Reference
)
4530 (Ekind
(Id
) = E_Entry_Family
4532 Nkind
(Parent
(Parent
(N
))) /= N_Attribute_Reference
))
4534 -- It is an entry call after all, either to the current task (which
4535 -- will deadlock) or to an enclosing task.
4537 Analyze_Selected_Component
(N
);
4541 Change_Selected_Component_To_Expanded_Name
(N
);
4543 -- Do style check and generate reference, but skip both steps if this
4544 -- entity has homonyms, since we may not have the right homonym set yet.
4545 -- The proper homonym will be set during the resolve phase.
4547 if Has_Homonym
(Id
) then
4550 Set_Entity_With_Style_Check
(N
, Id
);
4551 Generate_Reference
(Id
, N
);
4554 if Is_Type
(Id
) then
4557 Set_Etype
(N
, Get_Full_View
(Etype
(Id
)));
4560 -- If the Ekind of the entity is Void, it means that all homonyms are
4561 -- hidden from all visibility (RM 8.3(5,14-20)).
4563 if Ekind
(Id
) = E_Void
then
4564 Premature_Usage
(N
);
4566 elsif Is_Overloadable
(Id
)
4567 and then Present
(Homonym
(Id
))
4570 H
: Entity_Id
:= Homonym
(Id
);
4573 while Present
(H
) loop
4574 if Scope
(H
) = Scope
(Id
)
4577 or else Is_Immediately_Visible
(H
))
4579 Collect_Interps
(N
);
4586 -- If an extension of System is present, collect possible explicit
4587 -- overloadings declared in the extension.
4589 if Chars
(P_Name
) = Name_System
4590 and then Scope
(P_Name
) = Standard_Standard
4591 and then Present
(System_Extend_Unit
)
4592 and then Present_System_Aux
(N
)
4594 H
:= Current_Entity
(Id
);
4596 while Present
(H
) loop
4597 if Scope
(H
) = System_Aux_Id
then
4598 Add_One_Interp
(N
, H
, Etype
(H
));
4607 if Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
4608 and then Scope
(Id
) /= Standard_Standard
4610 -- In addition to user-defined operators in the given scope, there
4611 -- may be an implicit instance of the predefined operator. The
4612 -- operator (defined in Standard) is found in Has_Implicit_Operator,
4613 -- and added to the interpretations. Procedure Add_One_Interp will
4614 -- determine which hides which.
4616 if Has_Implicit_Operator
(N
) then
4620 end Find_Expanded_Name
;
4622 -------------------------
4623 -- Find_Renamed_Entity --
4624 -------------------------
4626 function Find_Renamed_Entity
4630 Is_Actual
: Boolean := False) return Entity_Id
4633 I1
: Interp_Index
:= 0; -- Suppress junk warnings
4639 function Enclosing_Instance
return Entity_Id
;
4640 -- If the renaming determines the entity for the default of a formal
4641 -- subprogram nested within another instance, choose the innermost
4642 -- candidate. This is because if the formal has a box, and we are within
4643 -- an enclosing instance where some candidate interpretations are local
4644 -- to this enclosing instance, we know that the default was properly
4645 -- resolved when analyzing the generic, so we prefer the local
4646 -- candidates to those that are external. This is not always the case
4647 -- but is a reasonable heuristic on the use of nested generics. The
4648 -- proper solution requires a full renaming model.
4650 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean;
4651 -- If the renamed entity is an implicit operator, check whether it is
4652 -- visible because its operand type is properly visible. This check
4653 -- applies to explicit renamed entities that appear in the source in a
4654 -- renaming declaration or a formal subprogram instance, but not to
4655 -- default generic actuals with a name.
4657 function Report_Overload
return Entity_Id
;
4658 -- List possible interpretations, and specialize message in the
4659 -- case of a generic actual.
4661 function Within
(Inner
, Outer
: Entity_Id
) return Boolean;
4662 -- Determine whether a candidate subprogram is defined within the
4663 -- enclosing instance. If yes, it has precedence over outer candidates.
4665 ------------------------
4666 -- Enclosing_Instance --
4667 ------------------------
4669 function Enclosing_Instance
return Entity_Id
is
4673 if not Is_Generic_Instance
(Current_Scope
)
4674 and then not Is_Actual
4679 S
:= Scope
(Current_Scope
);
4680 while S
/= Standard_Standard
loop
4681 if Is_Generic_Instance
(S
) then
4689 end Enclosing_Instance
;
4691 --------------------------
4692 -- Is_Visible_Operation --
4693 --------------------------
4695 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean is
4701 if Ekind
(Op
) /= E_Operator
4702 or else Scope
(Op
) /= Standard_Standard
4703 or else (In_Instance
4706 or else Present
(Enclosing_Instance
)))
4711 -- For a fixed point type operator, check the resulting type,
4712 -- because it may be a mixed mode integer * fixed operation.
4714 if Present
(Next_Formal
(First_Formal
(New_S
)))
4715 and then Is_Fixed_Point_Type
(Etype
(New_S
))
4717 Typ
:= Etype
(New_S
);
4719 Typ
:= Etype
(First_Formal
(New_S
));
4722 Btyp
:= Base_Type
(Typ
);
4724 if Nkind
(Nam
) /= N_Expanded_Name
then
4725 return (In_Open_Scopes
(Scope
(Btyp
))
4726 or else Is_Potentially_Use_Visible
(Btyp
)
4727 or else In_Use
(Btyp
)
4728 or else In_Use
(Scope
(Btyp
)));
4731 Scop
:= Entity
(Prefix
(Nam
));
4733 if Ekind
(Scop
) = E_Package
4734 and then Present
(Renamed_Object
(Scop
))
4736 Scop
:= Renamed_Object
(Scop
);
4739 -- Operator is visible if prefix of expanded name denotes
4740 -- scope of type, or else type type is defined in System_Aux
4741 -- and the prefix denotes System.
4743 return Scope
(Btyp
) = Scop
4744 or else (Scope
(Btyp
) = System_Aux_Id
4745 and then Scope
(Scope
(Btyp
)) = Scop
);
4748 end Is_Visible_Operation
;
4754 function Within
(Inner
, Outer
: Entity_Id
) return Boolean is
4758 Sc
:= Scope
(Inner
);
4759 while Sc
/= Standard_Standard
loop
4770 ---------------------
4771 -- Report_Overload --
4772 ---------------------
4774 function Report_Overload
return Entity_Id
is
4778 ("ambiguous actual subprogram&, " &
4779 "possible interpretations:", N
, Nam
);
4782 ("ambiguous subprogram, " &
4783 "possible interpretations:", N
);
4786 List_Interps
(Nam
, N
);
4788 end Report_Overload
;
4790 -- Start of processing for Find_Renamed_Entry
4794 Candidate_Renaming
:= Empty
;
4796 if not Is_Overloaded
(Nam
) then
4797 if Entity_Matches_Spec
(Entity
(Nam
), New_S
)
4798 and then Is_Visible_Operation
(Entity
(Nam
))
4800 Old_S
:= Entity
(Nam
);
4803 Present
(First_Formal
(Entity
(Nam
)))
4804 and then Present
(First_Formal
(New_S
))
4805 and then (Base_Type
(Etype
(First_Formal
(Entity
(Nam
))))
4806 = Base_Type
(Etype
(First_Formal
(New_S
))))
4808 Candidate_Renaming
:= Entity
(Nam
);
4812 Get_First_Interp
(Nam
, Ind
, It
);
4813 while Present
(It
.Nam
) loop
4814 if Entity_Matches_Spec
(It
.Nam
, New_S
)
4815 and then Is_Visible_Operation
(It
.Nam
)
4817 if Old_S
/= Any_Id
then
4819 -- Note: The call to Disambiguate only happens if a
4820 -- previous interpretation was found, in which case I1
4821 -- has received a value.
4823 It1
:= Disambiguate
(Nam
, I1
, Ind
, Etype
(Old_S
));
4825 if It1
= No_Interp
then
4826 Inst
:= Enclosing_Instance
;
4828 if Present
(Inst
) then
4829 if Within
(It
.Nam
, Inst
) then
4831 elsif Within
(Old_S
, Inst
) then
4834 return Report_Overload
;
4838 return Report_Overload
;
4852 Present
(First_Formal
(It
.Nam
))
4853 and then Present
(First_Formal
(New_S
))
4854 and then (Base_Type
(Etype
(First_Formal
(It
.Nam
)))
4855 = Base_Type
(Etype
(First_Formal
(New_S
))))
4857 Candidate_Renaming
:= It
.Nam
;
4860 Get_Next_Interp
(Ind
, It
);
4863 Set_Entity
(Nam
, Old_S
);
4864 Set_Is_Overloaded
(Nam
, False);
4868 end Find_Renamed_Entity
;
4870 -----------------------------
4871 -- Find_Selected_Component --
4872 -----------------------------
4874 procedure Find_Selected_Component
(N
: Node_Id
) is
4875 P
: constant Node_Id
:= Prefix
(N
);
4878 -- Entity denoted by prefix
4888 if Nkind
(P
) = N_Error
then
4891 -- If the selector already has an entity, the node has been constructed
4892 -- in the course of expansion, and is known to be valid. Do not verify
4893 -- that it is defined for the type (it may be a private component used
4894 -- in the expansion of record equality).
4896 elsif Present
(Entity
(Selector_Name
(N
))) then
4899 or else Etype
(N
) = Any_Type
4902 Sel_Name
: constant Node_Id
:= Selector_Name
(N
);
4903 Selector
: constant Entity_Id
:= Entity
(Sel_Name
);
4907 Set_Etype
(Sel_Name
, Etype
(Selector
));
4909 if not Is_Entity_Name
(P
) then
4913 -- Build an actual subtype except for the first parameter
4914 -- of an init proc, where this actual subtype is by
4915 -- definition incorrect, since the object is uninitialized
4916 -- (and does not even have defined discriminants etc.)
4918 if Is_Entity_Name
(P
)
4919 and then Ekind
(Entity
(P
)) = E_Function
4921 Nam
:= New_Copy
(P
);
4923 if Is_Overloaded
(P
) then
4924 Save_Interps
(P
, Nam
);
4928 Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
4930 Analyze_Selected_Component
(N
);
4933 elsif Ekind
(Selector
) = E_Component
4934 and then (not Is_Entity_Name
(P
)
4935 or else Chars
(Entity
(P
)) /= Name_uInit
)
4938 Build_Actual_Subtype_Of_Component
(
4939 Etype
(Selector
), N
);
4944 if No
(C_Etype
) then
4945 C_Etype
:= Etype
(Selector
);
4947 Insert_Action
(N
, C_Etype
);
4948 C_Etype
:= Defining_Identifier
(C_Etype
);
4951 Set_Etype
(N
, C_Etype
);
4954 -- If this is the name of an entry or protected operation, and
4955 -- the prefix is an access type, insert an explicit dereference,
4956 -- so that entry calls are treated uniformly.
4958 if Is_Access_Type
(Etype
(P
))
4959 and then Is_Concurrent_Type
(Designated_Type
(Etype
(P
)))
4962 New_P
: constant Node_Id
:=
4963 Make_Explicit_Dereference
(Sloc
(P
),
4964 Prefix
=> Relocate_Node
(P
));
4967 Set_Etype
(P
, Designated_Type
(Etype
(Prefix
(P
))));
4971 -- If the selected component appears within a default expression
4972 -- and it has an actual subtype, the pre-analysis has not yet
4973 -- completed its analysis, because Insert_Actions is disabled in
4974 -- that context. Within the init proc of the enclosing type we
4975 -- must complete this analysis, if an actual subtype was created.
4977 elsif Inside_Init_Proc
then
4979 Typ
: constant Entity_Id
:= Etype
(N
);
4980 Decl
: constant Node_Id
:= Declaration_Node
(Typ
);
4982 if Nkind
(Decl
) = N_Subtype_Declaration
4983 and then not Analyzed
(Decl
)
4984 and then Is_List_Member
(Decl
)
4985 and then No
(Parent
(Decl
))
4988 Insert_Action
(N
, Decl
);
4995 elsif Is_Entity_Name
(P
) then
4996 P_Name
:= Entity
(P
);
4998 -- The prefix may denote an enclosing type which is the completion
4999 -- of an incomplete type declaration.
5001 if Is_Type
(P_Name
) then
5002 Set_Entity
(P
, Get_Full_View
(P_Name
));
5003 Set_Etype
(P
, Entity
(P
));
5004 P_Name
:= Entity
(P
);
5007 P_Type
:= Base_Type
(Etype
(P
));
5009 if Debug_Flag_E
then
5010 Write_Str
("Found prefix type to be ");
5011 Write_Entity_Info
(P_Type
, " "); Write_Eol
;
5014 -- First check for components of a record object (not the
5015 -- result of a call, which is handled below).
5017 if Is_Appropriate_For_Record
(P_Type
)
5018 and then not Is_Overloadable
(P_Name
)
5019 and then not Is_Type
(P_Name
)
5021 -- Selected component of record. Type checking will validate
5022 -- name of selector.
5023 -- ??? could we rewrite an implicit dereference into an explicit
5026 Analyze_Selected_Component
(N
);
5028 elsif Is_Appropriate_For_Entry_Prefix
(P_Type
)
5029 and then not In_Open_Scopes
(P_Name
)
5030 and then (not Is_Concurrent_Type
(Etype
(P_Name
))
5031 or else not In_Open_Scopes
(Etype
(P_Name
)))
5033 -- Call to protected operation or entry. Type checking is
5034 -- needed on the prefix.
5036 Analyze_Selected_Component
(N
);
5038 elsif (In_Open_Scopes
(P_Name
)
5039 and then Ekind
(P_Name
) /= E_Void
5040 and then not Is_Overloadable
(P_Name
))
5041 or else (Is_Concurrent_Type
(Etype
(P_Name
))
5042 and then In_Open_Scopes
(Etype
(P_Name
)))
5044 -- Prefix denotes an enclosing loop, block, or task, i.e. an
5045 -- enclosing construct that is not a subprogram or accept.
5047 Find_Expanded_Name
(N
);
5049 elsif Ekind
(P_Name
) = E_Package
then
5050 Find_Expanded_Name
(N
);
5052 elsif Is_Overloadable
(P_Name
) then
5054 -- The subprogram may be a renaming (of an enclosing scope) as
5055 -- in the case of the name of the generic within an instantiation.
5057 if (Ekind
(P_Name
) = E_Procedure
5058 or else Ekind
(P_Name
) = E_Function
)
5059 and then Present
(Alias
(P_Name
))
5060 and then Is_Generic_Instance
(Alias
(P_Name
))
5062 P_Name
:= Alias
(P_Name
);
5065 if Is_Overloaded
(P
) then
5067 -- The prefix must resolve to a unique enclosing construct
5070 Found
: Boolean := False;
5075 Get_First_Interp
(P
, Ind
, It
);
5076 while Present
(It
.Nam
) loop
5077 if In_Open_Scopes
(It
.Nam
) then
5080 "prefix must be unique enclosing scope", N
);
5081 Set_Entity
(N
, Any_Id
);
5082 Set_Etype
(N
, Any_Type
);
5091 Get_Next_Interp
(Ind
, It
);
5096 if In_Open_Scopes
(P_Name
) then
5097 Set_Entity
(P
, P_Name
);
5098 Set_Is_Overloaded
(P
, False);
5099 Find_Expanded_Name
(N
);
5102 -- If no interpretation as an expanded name is possible, it
5103 -- must be a selected component of a record returned by a
5104 -- function call. Reformat prefix as a function call, the rest
5105 -- is done by type resolution. If the prefix is procedure or
5106 -- entry, as is P.X; this is an error.
5108 if Ekind
(P_Name
) /= E_Function
5109 and then (not Is_Overloaded
(P
)
5111 Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
)
5113 -- Prefix may mention a package that is hidden by a local
5114 -- declaration: let the user know. Scan the full homonym
5115 -- chain, the candidate package may be anywhere on it.
5117 if Present
(Homonym
(Current_Entity
(P_Name
))) then
5119 P_Name
:= Current_Entity
(P_Name
);
5121 while Present
(P_Name
) loop
5122 exit when Ekind
(P_Name
) = E_Package
;
5123 P_Name
:= Homonym
(P_Name
);
5126 if Present
(P_Name
) then
5127 Error_Msg_Sloc
:= Sloc
(Entity
(Prefix
(N
)));
5130 ("package& is hidden by declaration#",
5133 Set_Entity
(Prefix
(N
), P_Name
);
5134 Find_Expanded_Name
(N
);
5137 P_Name
:= Entity
(Prefix
(N
));
5142 ("invalid prefix in selected component&", N
, P_Name
);
5143 Change_Selected_Component_To_Expanded_Name
(N
);
5144 Set_Entity
(N
, Any_Id
);
5145 Set_Etype
(N
, Any_Type
);
5148 Nam
:= New_Copy
(P
);
5149 Save_Interps
(P
, Nam
);
5151 Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
5153 Analyze_Selected_Component
(N
);
5157 -- Remaining cases generate various error messages
5160 -- Format node as expanded name, to avoid cascaded errors
5162 Change_Selected_Component_To_Expanded_Name
(N
);
5163 Set_Entity
(N
, Any_Id
);
5164 Set_Etype
(N
, Any_Type
);
5166 -- Issue error message, but avoid this if error issued already.
5167 -- Use identifier of prefix if one is available.
5169 if P_Name
= Any_Id
then
5172 elsif Ekind
(P_Name
) = E_Void
then
5173 Premature_Usage
(P
);
5175 elsif Nkind
(P
) /= N_Attribute_Reference
then
5177 "invalid prefix in selected component&", P
);
5179 if Is_Access_Type
(P_Type
)
5180 and then Ekind
(Designated_Type
(P_Type
)) = E_Incomplete_Type
5183 ("\dereference must not be of an incomplete type " &
5189 "invalid prefix in selected component", P
);
5194 -- If prefix is not the name of an entity, it must be an expression,
5195 -- whose type is appropriate for a record. This is determined by
5198 Analyze_Selected_Component
(N
);
5200 end Find_Selected_Component
;
5206 procedure Find_Type
(N
: Node_Id
) is
5216 elsif Nkind
(N
) = N_Attribute_Reference
then
5218 -- Class attribute. This is not valid in Ada 83 mode, but we do not
5219 -- need to enforce that at this point, since the declaration of the
5220 -- tagged type in the prefix would have been flagged already.
5222 if Attribute_Name
(N
) = Name_Class
then
5223 Check_Restriction
(No_Dispatch
, N
);
5224 Find_Type
(Prefix
(N
));
5226 -- Propagate error from bad prefix
5228 if Etype
(Prefix
(N
)) = Any_Type
then
5229 Set_Entity
(N
, Any_Type
);
5230 Set_Etype
(N
, Any_Type
);
5234 T
:= Base_Type
(Entity
(Prefix
(N
)));
5236 -- Case where type is not known to be tagged. Its appearance in
5237 -- the prefix of the 'Class attribute indicates that the full view
5240 if not Is_Tagged_Type
(T
) then
5241 if Ekind
(T
) = E_Incomplete_Type
then
5243 -- It is legal to denote the class type of an incomplete
5244 -- type. The full type will have to be tagged, of course.
5245 -- In Ada 2005 this usage is declared obsolescent, so we
5246 -- warn accordingly.
5248 -- ??? This test is temporarily disabled (always False)
5249 -- because it causes an unwanted warning on GNAT sources
5250 -- (built with -gnatg, which includes Warn_On_Obsolescent_
5251 -- Feature). Once this issue is cleared in the sources, it
5254 if not Is_Tagged_Type
(T
)
5255 and then Ada_Version
>= Ada_05
5256 and then Warn_On_Obsolescent_Feature
5260 ("applying 'Class to an untagged imcomplete type"
5261 & " is an obsolescent feature (RM J.11)", N
);
5264 Set_Is_Tagged_Type
(T
);
5265 Set_Primitive_Operations
(T
, New_Elmt_List
);
5266 Make_Class_Wide_Type
(T
);
5267 Set_Entity
(N
, Class_Wide_Type
(T
));
5268 Set_Etype
(N
, Class_Wide_Type
(T
));
5270 elsif Ekind
(T
) = E_Private_Type
5271 and then not Is_Generic_Type
(T
)
5272 and then In_Private_Part
(Scope
(T
))
5274 -- The Class attribute can be applied to an untagged private
5275 -- type fulfilled by a tagged type prior to the full type
5276 -- declaration (but only within the parent package's private
5277 -- part). Create the class-wide type now and check that the
5278 -- full type is tagged later during its analysis. Note that
5279 -- we do not mark the private type as tagged, unlike the
5280 -- case of incomplete types, because the type must still
5281 -- appear untagged to outside units.
5283 if No
(Class_Wide_Type
(T
)) then
5284 Make_Class_Wide_Type
(T
);
5287 Set_Entity
(N
, Class_Wide_Type
(T
));
5288 Set_Etype
(N
, Class_Wide_Type
(T
));
5291 -- Should we introduce a type Any_Tagged and use Wrong_Type
5292 -- here, it would be a bit more consistent???
5295 ("tagged type required, found}",
5296 Prefix
(N
), First_Subtype
(T
));
5297 Set_Entity
(N
, Any_Type
);
5301 -- Case of tagged type
5304 if Is_Concurrent_Type
(T
) then
5305 if No
(Corresponding_Record_Type
(Entity
(Prefix
(N
)))) then
5307 -- Previous error. Use current type, which at least
5308 -- provides some operations.
5310 C
:= Entity
(Prefix
(N
));
5313 C
:= Class_Wide_Type
5314 (Corresponding_Record_Type
(Entity
(Prefix
(N
))));
5318 C
:= Class_Wide_Type
(Entity
(Prefix
(N
)));
5321 Set_Entity_With_Style_Check
(N
, C
);
5322 Generate_Reference
(C
, N
);
5326 -- Base attribute, not allowed in Ada 83
5328 elsif Attribute_Name
(N
) = Name_Base
then
5329 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5331 ("(Ada 83) Base attribute not allowed in subtype mark", N
);
5334 Find_Type
(Prefix
(N
));
5335 Typ
:= Entity
(Prefix
(N
));
5337 if Ada_Version
>= Ada_95
5338 and then not Is_Scalar_Type
(Typ
)
5339 and then not Is_Generic_Type
(Typ
)
5342 ("prefix of Base attribute must be scalar type",
5345 elsif Sloc
(Typ
) = Standard_Location
5346 and then Base_Type
(Typ
) = Typ
5347 and then Warn_On_Redundant_Constructs
5350 ("?redudant attribute, & is its own base type", N
, Typ
);
5353 T
:= Base_Type
(Typ
);
5355 -- Rewrite attribute reference with type itself (see similar
5356 -- processing in Analyze_Attribute, case Base). Preserve
5357 -- prefix if present, for other legality checks.
5359 if Nkind
(Prefix
(N
)) = N_Expanded_Name
then
5361 Make_Expanded_Name
(Sloc
(N
),
5363 Prefix
=> New_Copy
(Prefix
(Prefix
(N
))),
5364 Selector_Name
=> New_Reference_To
(T
, Sloc
(N
))));
5367 Rewrite
(N
, New_Reference_To
(T
, Sloc
(N
)));
5374 elsif Attribute_Name
(N
) = Name_Stub_Type
then
5376 -- This is handled in Analyze_Attribute
5380 -- All other attributes are invalid in a subtype mark
5383 Error_Msg_N
("invalid attribute in subtype mark", N
);
5389 if Is_Entity_Name
(N
) then
5390 T_Name
:= Entity
(N
);
5392 Error_Msg_N
("subtype mark required in this context", N
);
5393 Set_Etype
(N
, Any_Type
);
5397 if T_Name
= Any_Id
or else Etype
(N
) = Any_Type
then
5399 -- Undefined id. Make it into a valid type
5401 Set_Entity
(N
, Any_Type
);
5403 elsif not Is_Type
(T_Name
)
5404 and then T_Name
/= Standard_Void_Type
5406 Error_Msg_Sloc
:= Sloc
(T_Name
);
5407 Error_Msg_N
("subtype mark required in this context", N
);
5408 Error_Msg_NE
("\\found & declared#", N
, T_Name
);
5409 Set_Entity
(N
, Any_Type
);
5412 -- If the type is an incomplete type created to handle
5413 -- anonymous access components of a record type, then the
5414 -- incomplete type is the visible entity and subsequent
5415 -- references will point to it. Mark the original full
5416 -- type as referenced, to prevent spurious warnings.
5418 if Is_Incomplete_Type
(T_Name
)
5419 and then Present
(Full_View
(T_Name
))
5420 and then not Comes_From_Source
(T_Name
)
5422 Set_Referenced
(Full_View
(T_Name
));
5425 T_Name
:= Get_Full_View
(T_Name
);
5427 -- Ada 2005 (AI-251, AI-50217): Handle interfaces visible through
5428 -- limited-with clauses
5430 if From_With_Type
(T_Name
)
5431 and then Ekind
(T_Name
) in Incomplete_Kind
5432 and then Present
(Non_Limited_View
(T_Name
))
5433 and then Is_Interface
(Non_Limited_View
(T_Name
))
5435 T_Name
:= Non_Limited_View
(T_Name
);
5438 if In_Open_Scopes
(T_Name
) then
5439 if Ekind
(Base_Type
(T_Name
)) = E_Task_Type
then
5441 -- In Ada 2005, a task name can be used in an access
5442 -- definition within its own body.
5444 if Ada_Version
>= Ada_05
5445 and then Nkind
(Parent
(N
)) = N_Access_Definition
5447 Set_Entity
(N
, T_Name
);
5448 Set_Etype
(N
, T_Name
);
5453 ("task type cannot be used as type mark " &
5454 "within its own spec or body", N
);
5457 elsif Ekind
(Base_Type
(T_Name
)) = E_Protected_Type
then
5459 -- In Ada 2005, a protected name can be used in an access
5460 -- definition within its own body.
5462 if Ada_Version
>= Ada_05
5463 and then Nkind
(Parent
(N
)) = N_Access_Definition
5465 Set_Entity
(N
, T_Name
);
5466 Set_Etype
(N
, T_Name
);
5471 ("protected type cannot be used as type mark " &
5472 "within its own spec or body", N
);
5476 Error_Msg_N
("type declaration cannot refer to itself", N
);
5479 Set_Etype
(N
, Any_Type
);
5480 Set_Entity
(N
, Any_Type
);
5481 Set_Error_Posted
(T_Name
);
5485 Set_Entity
(N
, T_Name
);
5486 Set_Etype
(N
, T_Name
);
5490 if Present
(Etype
(N
)) and then Comes_From_Source
(N
) then
5491 if Is_Fixed_Point_Type
(Etype
(N
)) then
5492 Check_Restriction
(No_Fixed_Point
, N
);
5493 elsif Is_Floating_Point_Type
(Etype
(N
)) then
5494 Check_Restriction
(No_Floating_Point
, N
);
5499 ------------------------------------
5500 -- Has_Implicit_Character_Literal --
5501 ------------------------------------
5503 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean is
5505 Found
: Boolean := False;
5506 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
5507 Priv_Id
: Entity_Id
:= Empty
;
5510 if Ekind
(P
) = E_Package
5511 and then not In_Open_Scopes
(P
)
5513 Priv_Id
:= First_Private_Entity
(P
);
5516 if P
= Standard_Standard
then
5517 Change_Selected_Component_To_Expanded_Name
(N
);
5518 Rewrite
(N
, Selector_Name
(N
));
5520 Set_Etype
(Original_Node
(N
), Standard_Character
);
5524 Id
:= First_Entity
(P
);
5527 and then Id
/= Priv_Id
5529 if Is_Character_Type
(Id
)
5530 and then (Root_Type
(Id
) = Standard_Character
5531 or else Root_Type
(Id
) = Standard_Wide_Character
5532 or else Root_Type
(Id
) = Standard_Wide_Wide_Character
)
5533 and then Id
= Base_Type
(Id
)
5535 -- We replace the node with the literal itself, resolve as a
5536 -- character, and set the type correctly.
5539 Change_Selected_Component_To_Expanded_Name
(N
);
5540 Rewrite
(N
, Selector_Name
(N
));
5543 Set_Etype
(Original_Node
(N
), Id
);
5547 -- More than one type derived from Character in given scope.
5548 -- Collect all possible interpretations.
5550 Add_One_Interp
(N
, Id
, Id
);
5558 end Has_Implicit_Character_Literal
;
5560 ----------------------
5561 -- Has_Private_With --
5562 ----------------------
5564 function Has_Private_With
(E
: Entity_Id
) return Boolean is
5565 Comp_Unit
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
5569 Item
:= First
(Context_Items
(Comp_Unit
));
5570 while Present
(Item
) loop
5571 if Nkind
(Item
) = N_With_Clause
5572 and then Private_Present
(Item
)
5573 and then Entity
(Name
(Item
)) = E
5582 end Has_Private_With
;
5584 ---------------------------
5585 -- Has_Implicit_Operator --
5586 ---------------------------
5588 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean is
5589 Op_Id
: constant Name_Id
:= Chars
(Selector_Name
(N
));
5590 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
5592 Priv_Id
: Entity_Id
:= Empty
;
5594 procedure Add_Implicit_Operator
5596 Op_Type
: Entity_Id
:= Empty
);
5597 -- Add implicit interpretation to node N, using the type for which a
5598 -- predefined operator exists. If the operator yields a boolean type,
5599 -- the Operand_Type is implicitly referenced by the operator, and a
5600 -- reference to it must be generated.
5602 ---------------------------
5603 -- Add_Implicit_Operator --
5604 ---------------------------
5606 procedure Add_Implicit_Operator
5608 Op_Type
: Entity_Id
:= Empty
)
5610 Predef_Op
: Entity_Id
;
5613 Predef_Op
:= Current_Entity
(Selector_Name
(N
));
5615 while Present
(Predef_Op
)
5616 and then Scope
(Predef_Op
) /= Standard_Standard
5618 Predef_Op
:= Homonym
(Predef_Op
);
5621 if Nkind
(N
) = N_Selected_Component
then
5622 Change_Selected_Component_To_Expanded_Name
(N
);
5625 Add_One_Interp
(N
, Predef_Op
, T
);
5627 -- For operators with unary and binary interpretations, add both
5629 if Present
(Homonym
(Predef_Op
)) then
5630 Add_One_Interp
(N
, Homonym
(Predef_Op
), T
);
5633 -- The node is a reference to a predefined operator, and
5634 -- an implicit reference to the type of its operands.
5636 if Present
(Op_Type
) then
5637 Generate_Operator_Reference
(N
, Op_Type
);
5639 Generate_Operator_Reference
(N
, T
);
5641 end Add_Implicit_Operator
;
5643 -- Start of processing for Has_Implicit_Operator
5646 if Ekind
(P
) = E_Package
5647 and then not In_Open_Scopes
(P
)
5649 Priv_Id
:= First_Private_Entity
(P
);
5652 Id
:= First_Entity
(P
);
5656 -- Boolean operators: an implicit declaration exists if the scope
5657 -- contains a declaration for a derived Boolean type, or for an
5658 -- array of Boolean type.
5660 when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor
=>
5661 while Id
/= Priv_Id
loop
5662 if Valid_Boolean_Arg
(Id
)
5663 and then Id
= Base_Type
(Id
)
5665 Add_Implicit_Operator
(Id
);
5672 -- Equality: look for any non-limited type (result is Boolean)
5674 when Name_Op_Eq | Name_Op_Ne
=>
5675 while Id
/= Priv_Id
loop
5677 and then not Is_Limited_Type
(Id
)
5678 and then Id
= Base_Type
(Id
)
5680 Add_Implicit_Operator
(Standard_Boolean
, Id
);
5687 -- Comparison operators: scalar type, or array of scalar
5689 when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge
=>
5690 while Id
/= Priv_Id
loop
5691 if (Is_Scalar_Type
(Id
)
5692 or else (Is_Array_Type
(Id
)
5693 and then Is_Scalar_Type
(Component_Type
(Id
))))
5694 and then Id
= Base_Type
(Id
)
5696 Add_Implicit_Operator
(Standard_Boolean
, Id
);
5703 -- Arithmetic operators: any numeric type
5713 while Id
/= Priv_Id
loop
5714 if Is_Numeric_Type
(Id
)
5715 and then Id
= Base_Type
(Id
)
5717 Add_Implicit_Operator
(Id
);
5724 -- Concatenation: any one-dimensional array type
5726 when Name_Op_Concat
=>
5727 while Id
/= Priv_Id
loop
5728 if Is_Array_Type
(Id
) and then Number_Dimensions
(Id
) = 1
5729 and then Id
= Base_Type
(Id
)
5731 Add_Implicit_Operator
(Id
);
5738 -- What is the others condition here? Should we be using a
5739 -- subtype of Name_Id that would restrict to operators ???
5741 when others => null;
5744 -- If we fall through, then we do not have an implicit operator
5748 end Has_Implicit_Operator
;
5750 --------------------
5751 -- In_Open_Scopes --
5752 --------------------
5754 function In_Open_Scopes
(S
: Entity_Id
) return Boolean is
5756 -- Several scope stacks are maintained by Scope_Stack. The base of the
5757 -- currently active scope stack is denoted by the Is_Active_Stack_Base
5758 -- flag in the scope stack entry. Note that the scope stacks used to
5759 -- simply be delimited implicitly by the presence of Standard_Standard
5760 -- at their base, but there now are cases where this is not sufficient
5761 -- because Standard_Standard actually may appear in the middle of the
5762 -- active set of scopes.
5764 for J
in reverse 0 .. Scope_Stack
.Last
loop
5765 if Scope_Stack
.Table
(J
).Entity
= S
then
5769 -- Check Is_Active_Stack_Base to tell us when to stop, as there are
5770 -- cases where Standard_Standard appears in the middle of the active
5771 -- set of scopes. This affects the declaration and overriding of
5772 -- private inherited operations in instantiations of generic child
5775 exit when Scope_Stack
.Table
(J
).Is_Active_Stack_Base
;
5781 -----------------------------
5782 -- Inherit_Renamed_Profile --
5783 -----------------------------
5785 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
) is
5792 if Ekind
(Old_S
) = E_Operator
then
5793 New_F
:= First_Formal
(New_S
);
5795 while Present
(New_F
) loop
5796 Set_Etype
(New_F
, Base_Type
(Etype
(New_F
)));
5797 Next_Formal
(New_F
);
5800 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
5803 New_F
:= First_Formal
(New_S
);
5804 Old_F
:= First_Formal
(Old_S
);
5806 while Present
(New_F
) loop
5807 New_T
:= Etype
(New_F
);
5808 Old_T
:= Etype
(Old_F
);
5810 -- If the new type is a renaming of the old one, as is the
5811 -- case for actuals in instances, retain its name, to simplify
5812 -- later disambiguation.
5814 if Nkind
(Parent
(New_T
)) = N_Subtype_Declaration
5815 and then Is_Entity_Name
(Subtype_Indication
(Parent
(New_T
)))
5816 and then Entity
(Subtype_Indication
(Parent
(New_T
))) = Old_T
5820 Set_Etype
(New_F
, Old_T
);
5823 Next_Formal
(New_F
);
5824 Next_Formal
(Old_F
);
5827 if Ekind
(Old_S
) = E_Function
5828 or else Ekind
(Old_S
) = E_Enumeration_Literal
5830 Set_Etype
(New_S
, Etype
(Old_S
));
5833 end Inherit_Renamed_Profile
;
5839 procedure Initialize
is
5844 -------------------------
5845 -- Install_Use_Clauses --
5846 -------------------------
5848 procedure Install_Use_Clauses
5850 Force_Installation
: Boolean := False)
5858 while Present
(U
) loop
5860 -- Case of USE package
5862 if Nkind
(U
) = N_Use_Package_Clause
then
5863 P
:= First
(Names
(U
));
5864 while Present
(P
) loop
5867 if Ekind
(Id
) = E_Package
then
5869 Note_Redundant_Use
(P
);
5871 elsif Present
(Renamed_Object
(Id
))
5872 and then In_Use
(Renamed_Object
(Id
))
5874 Note_Redundant_Use
(P
);
5876 elsif Force_Installation
or else Applicable_Use
(P
) then
5877 Use_One_Package
(Id
, U
);
5888 P
:= First
(Subtype_Marks
(U
));
5889 while Present
(P
) loop
5890 if not Is_Entity_Name
(P
)
5891 or else No
(Entity
(P
))
5895 elsif Entity
(P
) /= Any_Type
then
5903 Next_Use_Clause
(U
);
5905 end Install_Use_Clauses
;
5907 -------------------------------------
5908 -- Is_Appropriate_For_Entry_Prefix --
5909 -------------------------------------
5911 function Is_Appropriate_For_Entry_Prefix
(T
: Entity_Id
) return Boolean is
5912 P_Type
: Entity_Id
:= T
;
5915 if Is_Access_Type
(P_Type
) then
5916 P_Type
:= Designated_Type
(P_Type
);
5919 return Is_Task_Type
(P_Type
) or else Is_Protected_Type
(P_Type
);
5920 end Is_Appropriate_For_Entry_Prefix
;
5922 -------------------------------
5923 -- Is_Appropriate_For_Record --
5924 -------------------------------
5926 function Is_Appropriate_For_Record
(T
: Entity_Id
) return Boolean is
5928 function Has_Components
(T1
: Entity_Id
) return Boolean;
5929 -- Determine if given type has components (i.e. is either a record
5930 -- type or a type that has discriminants).
5932 --------------------
5933 -- Has_Components --
5934 --------------------
5936 function Has_Components
(T1
: Entity_Id
) return Boolean is
5938 return Is_Record_Type
(T1
)
5939 or else (Is_Private_Type
(T1
) and then Has_Discriminants
(T1
))
5940 or else (Is_Task_Type
(T1
) and then Has_Discriminants
(T1
))
5941 or else (Is_Incomplete_Type
(T1
)
5942 and then From_With_Type
(T1
)
5943 and then Present
(Non_Limited_View
(T1
))
5944 and then Is_Record_Type
5945 (Get_Full_View
(Non_Limited_View
(T1
))));
5948 -- Start of processing for Is_Appropriate_For_Record
5953 and then (Has_Components
(T
)
5954 or else (Is_Access_Type
(T
)
5955 and then Has_Components
(Designated_Type
(T
))));
5956 end Is_Appropriate_For_Record
;
5958 ------------------------
5959 -- Note_Redundant_Use --
5960 ------------------------
5962 procedure Note_Redundant_Use
(Clause
: Node_Id
) is
5963 Pack_Name
: constant Entity_Id
:= Entity
(Clause
);
5964 Cur_Use
: constant Node_Id
:= Current_Use_Clause
(Pack_Name
);
5965 Decl
: constant Node_Id
:= Parent
(Clause
);
5967 Prev_Use
: Node_Id
:= Empty
;
5968 Redundant
: Node_Id
:= Empty
;
5969 -- The Use_Clause which is actually redundant. In the simplest case
5970 -- it is Pack itself, but when we compile a body we install its
5971 -- context before that of its spec, in which case it is the use_clause
5972 -- in the spec that will appear to be redundant, and we want the
5973 -- warning to be placed on the body. Similar complications appear when
5974 -- the redundancy is between a child unit and one of its ancestors.
5977 Set_Redundant_Use
(Clause
, True);
5979 if not Comes_From_Source
(Clause
)
5981 or else not Warn_On_Redundant_Constructs
5986 if not Is_Compilation_Unit
(Current_Scope
) then
5988 -- If the use_clause is in an inner scope, it is made redundant
5989 -- by some clause in the current context, with one exception:
5990 -- If we're compiling a nested package body, and the use_clause
5991 -- comes from the corresponding spec, the clause is not necessarily
5992 -- fully redundant, so we should not warn. If a warning was
5993 -- warranted, it would have been given when the spec was processed.
5995 if Nkind
(Parent
(Decl
)) = N_Package_Specification
then
5997 Package_Spec_Entity
: constant Entity_Id
:=
5998 Defining_Unit_Name
(Parent
(Decl
));
6000 if In_Package_Body
(Package_Spec_Entity
) then
6006 Redundant
:= Clause
;
6007 Prev_Use
:= Cur_Use
;
6009 elsif Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
then
6011 Cur_Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(Cur_Use
);
6012 New_Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(Clause
);
6016 if Cur_Unit
= New_Unit
then
6018 -- Redundant clause in same body
6020 Redundant
:= Clause
;
6021 Prev_Use
:= Cur_Use
;
6023 elsif Cur_Unit
= Current_Sem_Unit
then
6025 -- If the new clause is not in the current unit it has been
6026 -- analyzed first, and it makes the other one redundant.
6027 -- However, if the new clause appears in a subunit, Cur_Unit
6028 -- is still the parent, and in that case the redundant one
6029 -- is the one appearing in the subunit.
6031 if Nkind
(Unit
(Cunit
(New_Unit
))) = N_Subunit
then
6032 Redundant
:= Clause
;
6033 Prev_Use
:= Cur_Use
;
6035 -- Most common case: redundant clause in body,
6036 -- original clause in spec. Current scope is spec entity.
6041 Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
))))
6043 Redundant
:= Cur_Use
;
6047 -- The new clause may appear in an unrelated unit, when
6048 -- the parents of a generic are being installed prior to
6049 -- instantiation. In this case there must be no warning.
6050 -- We detect this case by checking whether the current top
6051 -- of the stack is related to the current compilation.
6053 Scop
:= Current_Scope
;
6054 while Present
(Scop
)
6055 and then Scop
/= Standard_Standard
6057 if Is_Compilation_Unit
(Scop
)
6058 and then not Is_Child_Unit
(Scop
)
6062 elsif Scop
= Cunit_Entity
(Current_Sem_Unit
) then
6066 Scop
:= Scope
(Scop
);
6069 Redundant
:= Cur_Use
;
6073 elsif New_Unit
= Current_Sem_Unit
then
6074 Redundant
:= Clause
;
6075 Prev_Use
:= Cur_Use
;
6078 -- Neither is the current unit, so they appear in parent or
6079 -- sibling units. Warning will be emitted elsewhere.
6085 elsif Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
6086 and then Present
(Parent_Spec
(Unit
(Cunit
(Current_Sem_Unit
))))
6088 -- Use_clause is in child unit of current unit, and the child
6089 -- unit appears in the context of the body of the parent, so it
6090 -- has been installed first, even though it is the redundant one.
6091 -- Depending on their placement in the context, the visible or the
6092 -- private parts of the two units, either might appear as redundant,
6093 -- but the message has to be on the current unit.
6095 if Get_Source_Unit
(Cur_Use
) = Current_Sem_Unit
then
6096 Redundant
:= Cur_Use
;
6099 Redundant
:= Clause
;
6100 Prev_Use
:= Cur_Use
;
6103 -- If the new use clause appears in the private part of a parent unit
6104 -- it may appear to be redudant w.r.t. a use clause in a child unit,
6105 -- but the previous use clause was needed in the visible part of the
6106 -- child, and no warning should be emitted.
6108 if Nkind
(Parent
(Decl
)) = N_Package_Specification
6110 List_Containing
(Decl
) = Private_Declarations
(Parent
(Decl
))
6113 Par
: constant Entity_Id
:= Defining_Entity
(Parent
(Decl
));
6114 Spec
: constant Node_Id
:=
6115 Specification
(Unit
(Cunit
(Current_Sem_Unit
)));
6118 if Is_Compilation_Unit
(Par
)
6119 and then Par
/= Cunit_Entity
(Current_Sem_Unit
)
6120 and then Parent
(Cur_Use
) = Spec
6122 List_Containing
(Cur_Use
) = Visible_Declarations
(Spec
)
6133 if Present
(Redundant
) then
6134 Error_Msg_Sloc
:= Sloc
(Prev_Use
);
6136 ("& is already use-visible through previous use clause #?",
6137 Redundant
, Pack_Name
);
6139 end Note_Redundant_Use
;
6145 procedure Pop_Scope
is
6146 SST
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
6149 if Debug_Flag_E
then
6153 Scope_Suppress
:= SST
.Save_Scope_Suppress
;
6154 Local_Suppress_Stack_Top
:= SST
.Save_Local_Suppress_Stack_Top
;
6156 if Debug_Flag_W
then
6157 Write_Str
("--> exiting scope: ");
6158 Write_Name
(Chars
(Current_Scope
));
6159 Write_Str
(", Depth=");
6160 Write_Int
(Int
(Scope_Stack
.Last
));
6164 End_Use_Clauses
(SST
.First_Use_Clause
);
6166 -- If the actions to be wrapped are still there they will get lost
6167 -- causing incomplete code to be generated. It is better to abort in
6168 -- this case (and we do the abort even with assertions off since the
6169 -- penalty is incorrect code generation)
6171 if SST
.Actions_To_Be_Wrapped_Before
/= No_List
6173 SST
.Actions_To_Be_Wrapped_After
/= No_List
6178 -- Free last subprogram name if allocated, and pop scope
6180 Free
(SST
.Last_Subprogram_Name
);
6181 Scope_Stack
.Decrement_Last
;
6188 procedure Push_Scope
(S
: Entity_Id
) is
6192 if Ekind
(S
) = E_Void
then
6195 -- Set scope depth if not a non-concurrent type, and we have not
6196 -- yet set the scope depth. This means that we have the first
6197 -- occurrence of the scope, and this is where the depth is set.
6199 elsif (not Is_Type
(S
) or else Is_Concurrent_Type
(S
))
6200 and then not Scope_Depth_Set
(S
)
6202 if S
= Standard_Standard
then
6203 Set_Scope_Depth_Value
(S
, Uint_0
);
6205 elsif Is_Child_Unit
(S
) then
6206 Set_Scope_Depth_Value
(S
, Uint_1
);
6208 elsif not Is_Record_Type
(Current_Scope
) then
6209 if Ekind
(S
) = E_Loop
then
6210 Set_Scope_Depth_Value
(S
, Scope_Depth
(Current_Scope
));
6212 Set_Scope_Depth_Value
(S
, Scope_Depth
(Current_Scope
) + 1);
6217 Scope_Stack
.Increment_Last
;
6220 SST
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
6224 SST
.Save_Scope_Suppress
:= Scope_Suppress
;
6225 SST
.Save_Local_Suppress_Stack_Top
:= Local_Suppress_Stack_Top
;
6227 if Scope_Stack
.Last
> Scope_Stack
.First
then
6228 SST
.Component_Alignment_Default
:= Scope_Stack
.Table
6229 (Scope_Stack
.Last
- 1).
6230 Component_Alignment_Default
;
6233 SST
.Last_Subprogram_Name
:= null;
6234 SST
.Is_Transient
:= False;
6235 SST
.Node_To_Be_Wrapped
:= Empty
;
6236 SST
.Pending_Freeze_Actions
:= No_List
;
6237 SST
.Actions_To_Be_Wrapped_Before
:= No_List
;
6238 SST
.Actions_To_Be_Wrapped_After
:= No_List
;
6239 SST
.First_Use_Clause
:= Empty
;
6240 SST
.Is_Active_Stack_Base
:= False;
6241 SST
.Previous_Visibility
:= False;
6244 if Debug_Flag_W
then
6245 Write_Str
("--> new scope: ");
6246 Write_Name
(Chars
(Current_Scope
));
6247 Write_Str
(", Id=");
6248 Write_Int
(Int
(Current_Scope
));
6249 Write_Str
(", Depth=");
6250 Write_Int
(Int
(Scope_Stack
.Last
));
6254 -- Deal with copying flags from the previous scope to this one. This
6255 -- is not necessary if either scope is standard, or if the new scope
6258 if S
/= Standard_Standard
6259 and then Scope
(S
) /= Standard_Standard
6260 and then not Is_Child_Unit
(S
)
6264 if Nkind
(E
) not in N_Entity
then
6268 -- Copy categorization flags from Scope (S) to S, this is not done
6269 -- when Scope (S) is Standard_Standard since propagation is from
6270 -- library unit entity inwards. Copy other relevant attributes as
6271 -- well (Discard_Names in particular).
6273 -- We only propagate inwards for library level entities,
6274 -- inner level subprograms do not inherit the categorization.
6276 if Is_Library_Level_Entity
(S
) then
6277 Set_Is_Preelaborated
(S
, Is_Preelaborated
(E
));
6278 Set_Is_Shared_Passive
(S
, Is_Shared_Passive
(E
));
6279 Set_Discard_Names
(S
, Discard_Names
(E
));
6280 Set_Suppress_Value_Tracking_On_Call
6281 (S
, Suppress_Value_Tracking_On_Call
(E
));
6282 Set_Categorization_From_Scope
(E
=> S
, Scop
=> E
);
6287 ---------------------
6288 -- Premature_Usage --
6289 ---------------------
6291 procedure Premature_Usage
(N
: Node_Id
) is
6292 Kind
: constant Node_Kind
:= Nkind
(Parent
(Entity
(N
)));
6293 E
: Entity_Id
:= Entity
(N
);
6296 -- Within an instance, the analysis of the actual for a formal object
6297 -- does not see the name of the object itself. This is significant only
6298 -- if the object is an aggregate, where its analysis does not do any
6299 -- name resolution on component associations. (see 4717-008). In such a
6300 -- case, look for the visible homonym on the chain.
6303 and then Present
(Homonym
(E
))
6308 and then not In_Open_Scopes
(Scope
(E
))
6315 Set_Etype
(N
, Etype
(E
));
6320 if Kind
= N_Component_Declaration
then
6322 ("component&! cannot be used before end of record declaration", N
);
6324 elsif Kind
= N_Parameter_Specification
then
6326 ("formal parameter&! cannot be used before end of specification",
6329 elsif Kind
= N_Discriminant_Specification
then
6331 ("discriminant&! cannot be used before end of discriminant part",
6334 elsif Kind
= N_Procedure_Specification
6335 or else Kind
= N_Function_Specification
6338 ("subprogram&! cannot be used before end of its declaration",
6341 elsif Kind
= N_Full_Type_Declaration
then
6343 ("type& cannot be used before end of its declaration!", N
);
6347 ("object& cannot be used before end of its declaration!", N
);
6349 end Premature_Usage
;
6351 ------------------------
6352 -- Present_System_Aux --
6353 ------------------------
6355 function Present_System_Aux
(N
: Node_Id
:= Empty
) return Boolean is
6357 Aux_Name
: Unit_Name_Type
;
6358 Unum
: Unit_Number_Type
;
6363 function Find_System
(C_Unit
: Node_Id
) return Entity_Id
;
6364 -- Scan context clause of compilation unit to find with_clause
6371 function Find_System
(C_Unit
: Node_Id
) return Entity_Id
is
6372 With_Clause
: Node_Id
;
6375 With_Clause
:= First
(Context_Items
(C_Unit
));
6376 while Present
(With_Clause
) loop
6377 if (Nkind
(With_Clause
) = N_With_Clause
6378 and then Chars
(Name
(With_Clause
)) = Name_System
)
6379 and then Comes_From_Source
(With_Clause
)
6390 -- Start of processing for Present_System_Aux
6393 -- The child unit may have been loaded and analyzed already
6395 if Present
(System_Aux_Id
) then
6398 -- If no previous pragma for System.Aux, nothing to load
6400 elsif No
(System_Extend_Unit
) then
6403 -- Use the unit name given in the pragma to retrieve the unit.
6404 -- Verify that System itself appears in the context clause of the
6405 -- current compilation. If System is not present, an error will
6406 -- have been reported already.
6409 With_Sys
:= Find_System
(Cunit
(Current_Sem_Unit
));
6411 The_Unit
:= Unit
(Cunit
(Current_Sem_Unit
));
6415 (Nkind
(The_Unit
) = N_Package_Body
6416 or else (Nkind
(The_Unit
) = N_Subprogram_Body
6418 not Acts_As_Spec
(Cunit
(Current_Sem_Unit
))))
6420 With_Sys
:= Find_System
(Library_Unit
(Cunit
(Current_Sem_Unit
)));
6424 and then Present
(N
)
6426 -- If we are compiling a subunit, we need to examine its
6427 -- context as well (Current_Sem_Unit is the parent unit);
6429 The_Unit
:= Parent
(N
);
6430 while Nkind
(The_Unit
) /= N_Compilation_Unit
loop
6431 The_Unit
:= Parent
(The_Unit
);
6434 if Nkind
(Unit
(The_Unit
)) = N_Subunit
then
6435 With_Sys
:= Find_System
(The_Unit
);
6439 if No
(With_Sys
) then
6443 Loc
:= Sloc
(With_Sys
);
6444 Get_Name_String
(Chars
(Expression
(System_Extend_Unit
)));
6445 Name_Buffer
(8 .. Name_Len
+ 7) := Name_Buffer
(1 .. Name_Len
);
6446 Name_Buffer
(1 .. 7) := "system.";
6447 Name_Buffer
(Name_Len
+ 8) := '%';
6448 Name_Buffer
(Name_Len
+ 9) := 's';
6449 Name_Len
:= Name_Len
+ 9;
6450 Aux_Name
:= Name_Find
;
6454 (Load_Name
=> Aux_Name
,
6457 Error_Node
=> With_Sys
);
6459 if Unum
/= No_Unit
then
6460 Semantics
(Cunit
(Unum
));
6462 Defining_Entity
(Specification
(Unit
(Cunit
(Unum
))));
6465 Make_With_Clause
(Loc
,
6467 Make_Expanded_Name
(Loc
,
6468 Chars
=> Chars
(System_Aux_Id
),
6469 Prefix
=> New_Reference_To
(Scope
(System_Aux_Id
), Loc
),
6470 Selector_Name
=> New_Reference_To
(System_Aux_Id
, Loc
)));
6472 Set_Entity
(Name
(Withn
), System_Aux_Id
);
6474 Set_Library_Unit
(Withn
, Cunit
(Unum
));
6475 Set_Corresponding_Spec
(Withn
, System_Aux_Id
);
6476 Set_First_Name
(Withn
, True);
6477 Set_Implicit_With
(Withn
, True);
6479 Insert_After
(With_Sys
, Withn
);
6480 Mark_Rewrite_Insertion
(Withn
);
6481 Set_Context_Installed
(Withn
);
6485 -- Here if unit load failed
6488 Error_Msg_Name_1
:= Name_System
;
6489 Error_Msg_Name_2
:= Chars
(Expression
(System_Extend_Unit
));
6491 ("extension package `%.%` does not exist",
6492 Opt
.System_Extend_Unit
);
6496 end Present_System_Aux
;
6498 -------------------------
6499 -- Restore_Scope_Stack --
6500 -------------------------
6502 procedure Restore_Scope_Stack
(Handle_Use
: Boolean := True) is
6505 Comp_Unit
: Node_Id
;
6506 In_Child
: Boolean := False;
6507 Full_Vis
: Boolean := True;
6508 SS_Last
: constant Int
:= Scope_Stack
.Last
;
6511 -- Restore visibility of previous scope stack, if any
6513 for J
in reverse 0 .. Scope_Stack
.Last
loop
6514 exit when Scope_Stack
.Table
(J
).Entity
= Standard_Standard
6515 or else No
(Scope_Stack
.Table
(J
).Entity
);
6517 S
:= Scope_Stack
.Table
(J
).Entity
;
6519 if not Is_Hidden_Open_Scope
(S
) then
6521 -- If the parent scope is hidden, its entities are hidden as
6522 -- well, unless the entity is the instantiation currently
6525 if not Is_Hidden_Open_Scope
(Scope
(S
))
6526 or else not Analyzed
(Parent
(S
))
6527 or else Scope
(S
) = Standard_Standard
6529 Set_Is_Immediately_Visible
(S
, True);
6532 E
:= First_Entity
(S
);
6533 while Present
(E
) loop
6534 if Is_Child_Unit
(E
) then
6535 Set_Is_Immediately_Visible
(E
,
6536 Is_Visible_Child_Unit
(E
) or else In_Open_Scopes
(E
));
6538 Set_Is_Immediately_Visible
(E
, True);
6543 if not Full_Vis
then
6544 exit when E
= First_Private_Entity
(S
);
6548 -- The visibility of child units (siblings of current compilation)
6549 -- must be restored in any case. Their declarations may appear
6550 -- after the private part of the parent.
6552 if not Full_Vis
then
6553 while Present
(E
) loop
6554 if Is_Child_Unit
(E
) then
6555 Set_Is_Immediately_Visible
(E
,
6556 Is_Visible_Child_Unit
(E
) or else In_Open_Scopes
(E
));
6564 if Is_Child_Unit
(S
)
6565 and not In_Child
-- check only for current unit
6569 -- Restore visibility of parents according to whether the child
6570 -- is private and whether we are in its visible part.
6572 Comp_Unit
:= Parent
(Unit_Declaration_Node
(S
));
6574 if Nkind
(Comp_Unit
) = N_Compilation_Unit
6575 and then Private_Present
(Comp_Unit
)
6579 elsif (Ekind
(S
) = E_Package
6580 or else Ekind
(S
) = E_Generic_Package
)
6581 and then (In_Private_Part
(S
)
6582 or else In_Package_Body
(S
))
6586 elsif (Ekind
(S
) = E_Procedure
6587 or else Ekind
(S
) = E_Function
)
6588 and then Has_Completion
(S
)
6599 if SS_Last
>= Scope_Stack
.First
6600 and then Scope_Stack
.Table
(SS_Last
).Entity
/= Standard_Standard
6603 Install_Use_Clauses
(Scope_Stack
.Table
(SS_Last
).First_Use_Clause
);
6605 end Restore_Scope_Stack
;
6607 ----------------------
6608 -- Save_Scope_Stack --
6609 ----------------------
6611 procedure Save_Scope_Stack
(Handle_Use
: Boolean := True) is
6614 SS_Last
: constant Int
:= Scope_Stack
.Last
;
6617 if SS_Last
>= Scope_Stack
.First
6618 and then Scope_Stack
.Table
(SS_Last
).Entity
/= Standard_Standard
6621 End_Use_Clauses
(Scope_Stack
.Table
(SS_Last
).First_Use_Clause
);
6624 -- If the call is from within a compilation unit, as when called from
6625 -- Rtsfind, make current entries in scope stack invisible while we
6626 -- analyze the new unit.
6628 for J
in reverse 0 .. SS_Last
loop
6629 exit when Scope_Stack
.Table
(J
).Entity
= Standard_Standard
6630 or else No
(Scope_Stack
.Table
(J
).Entity
);
6632 S
:= Scope_Stack
.Table
(J
).Entity
;
6633 Set_Is_Immediately_Visible
(S
, False);
6635 E
:= First_Entity
(S
);
6636 while Present
(E
) loop
6637 Set_Is_Immediately_Visible
(E
, False);
6643 end Save_Scope_Stack
;
6649 procedure Set_Use
(L
: List_Id
) is
6651 Pack_Name
: Node_Id
;
6658 while Present
(Decl
) loop
6659 if Nkind
(Decl
) = N_Use_Package_Clause
then
6660 Chain_Use_Clause
(Decl
);
6662 Pack_Name
:= First
(Names
(Decl
));
6663 while Present
(Pack_Name
) loop
6664 Pack
:= Entity
(Pack_Name
);
6666 if Ekind
(Pack
) = E_Package
6667 and then Applicable_Use
(Pack_Name
)
6669 Use_One_Package
(Pack
, Decl
);
6675 elsif Nkind
(Decl
) = N_Use_Type_Clause
then
6676 Chain_Use_Clause
(Decl
);
6678 Id
:= First
(Subtype_Marks
(Decl
));
6679 while Present
(Id
) loop
6680 if Entity
(Id
) /= Any_Type
then
6693 ---------------------
6694 -- Use_One_Package --
6695 ---------------------
6697 procedure Use_One_Package
(P
: Entity_Id
; N
: Node_Id
) is
6700 Current_Instance
: Entity_Id
:= Empty
;
6702 Private_With_OK
: Boolean := False;
6705 if Ekind
(P
) /= E_Package
then
6710 Set_Current_Use_Clause
(P
, N
);
6712 -- Ada 2005 (AI-50217): Check restriction
6714 if From_With_Type
(P
) then
6715 Error_Msg_N
("limited withed package cannot appear in use clause", N
);
6718 -- Find enclosing instance, if any
6721 Current_Instance
:= Current_Scope
;
6722 while not Is_Generic_Instance
(Current_Instance
) loop
6723 Current_Instance
:= Scope
(Current_Instance
);
6726 if No
(Hidden_By_Use_Clause
(N
)) then
6727 Set_Hidden_By_Use_Clause
(N
, New_Elmt_List
);
6731 -- If unit is a package renaming, indicate that the renamed
6732 -- package is also in use (the flags on both entities must
6733 -- remain consistent, and a subsequent use of either of them
6734 -- should be recognized as redundant).
6736 if Present
(Renamed_Object
(P
)) then
6737 Set_In_Use
(Renamed_Object
(P
));
6738 Set_Current_Use_Clause
(Renamed_Object
(P
), N
);
6739 Real_P
:= Renamed_Object
(P
);
6744 -- Ada 2005 (AI-262): Check the use_clause of a private withed package
6745 -- found in the private part of a package specification
6747 if In_Private_Part
(Current_Scope
)
6748 and then Has_Private_With
(P
)
6749 and then Is_Child_Unit
(Current_Scope
)
6750 and then Is_Child_Unit
(P
)
6751 and then Is_Ancestor_Package
(Scope
(Current_Scope
), P
)
6753 Private_With_OK
:= True;
6756 -- Loop through entities in one package making them potentially
6759 Id
:= First_Entity
(P
);
6761 and then (Id
/= First_Private_Entity
(P
)
6762 or else Private_With_OK
) -- Ada 2005 (AI-262)
6764 Prev
:= Current_Entity
(Id
);
6765 while Present
(Prev
) loop
6766 if Is_Immediately_Visible
(Prev
)
6767 and then (not Is_Overloadable
(Prev
)
6768 or else not Is_Overloadable
(Id
)
6769 or else (Type_Conformant
(Id
, Prev
)))
6771 if No
(Current_Instance
) then
6773 -- Potentially use-visible entity remains hidden
6775 goto Next_Usable_Entity
;
6777 -- A use clause within an instance hides outer global entities,
6778 -- which are not used to resolve local entities in the
6779 -- instance. Note that the predefined entities in Standard
6780 -- could not have been hidden in the generic by a use clause,
6781 -- and therefore remain visible. Other compilation units whose
6782 -- entities appear in Standard must be hidden in an instance.
6784 -- To determine whether an entity is external to the instance
6785 -- we compare the scope depth of its scope with that of the
6786 -- current instance. However, a generic actual of a subprogram
6787 -- instance is declared in the wrapper package but will not be
6788 -- hidden by a use-visible entity.
6790 -- If Id is called Standard, the predefined package with the
6791 -- same name is in the homonym chain. It has to be ignored
6792 -- because it has no defined scope (being the only entity in
6793 -- the system with this mandated behavior).
6795 elsif not Is_Hidden
(Id
)
6796 and then Present
(Scope
(Prev
))
6797 and then not Is_Wrapper_Package
(Scope
(Prev
))
6798 and then Scope_Depth
(Scope
(Prev
)) <
6799 Scope_Depth
(Current_Instance
)
6800 and then (Scope
(Prev
) /= Standard_Standard
6801 or else Sloc
(Prev
) > Standard_Location
)
6803 Set_Is_Potentially_Use_Visible
(Id
);
6804 Set_Is_Immediately_Visible
(Prev
, False);
6805 Append_Elmt
(Prev
, Hidden_By_Use_Clause
(N
));
6808 -- A user-defined operator is not use-visible if the predefined
6809 -- operator for the type is immediately visible, which is the case
6810 -- if the type of the operand is in an open scope. This does not
6811 -- apply to user-defined operators that have operands of different
6812 -- types, because the predefined mixed mode operations (multiply
6813 -- and divide) apply to universal types and do not hide anything.
6815 elsif Ekind
(Prev
) = E_Operator
6816 and then Operator_Matches_Spec
(Prev
, Id
)
6817 and then In_Open_Scopes
6818 (Scope
(Base_Type
(Etype
(First_Formal
(Id
)))))
6819 and then (No
(Next_Formal
(First_Formal
(Id
)))
6820 or else Etype
(First_Formal
(Id
))
6821 = Etype
(Next_Formal
(First_Formal
(Id
)))
6822 or else Chars
(Prev
) = Name_Op_Expon
)
6824 goto Next_Usable_Entity
;
6827 Prev
:= Homonym
(Prev
);
6830 -- On exit, we know entity is not hidden, unless it is private
6832 if not Is_Hidden
(Id
)
6833 and then ((not Is_Child_Unit
(Id
))
6834 or else Is_Visible_Child_Unit
(Id
))
6836 Set_Is_Potentially_Use_Visible
(Id
);
6838 if Is_Private_Type
(Id
)
6839 and then Present
(Full_View
(Id
))
6841 Set_Is_Potentially_Use_Visible
(Full_View
(Id
));
6845 <<Next_Usable_Entity
>>
6849 -- Child units are also made use-visible by a use clause, but they may
6850 -- appear after all visible declarations in the parent entity list.
6852 while Present
(Id
) loop
6853 if Is_Child_Unit
(Id
)
6854 and then Is_Visible_Child_Unit
(Id
)
6856 Set_Is_Potentially_Use_Visible
(Id
);
6862 if Chars
(Real_P
) = Name_System
6863 and then Scope
(Real_P
) = Standard_Standard
6864 and then Present_System_Aux
(N
)
6866 Use_One_Package
(System_Aux_Id
, N
);
6869 end Use_One_Package
;
6875 procedure Use_One_Type
(Id
: Node_Id
) is
6877 Is_Known_Used
: Boolean;
6881 function Spec_Reloaded_For_Body
return Boolean;
6882 -- Determine whether the compilation unit is a package body and the use
6883 -- type clause is in the spec of the same package. Even though the spec
6884 -- was analyzed first, its context is reloaded when analysing the body.
6886 ----------------------------
6887 -- Spec_Reloaded_For_Body --
6888 ----------------------------
6890 function Spec_Reloaded_For_Body
return Boolean is
6892 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
then
6894 Spec
: constant Node_Id
:=
6895 Parent
(List_Containing
(Parent
(Id
)));
6898 Nkind
(Spec
) = N_Package_Specification
6899 and then Corresponding_Body
(Parent
(Spec
)) =
6900 Cunit_Entity
(Current_Sem_Unit
);
6905 end Spec_Reloaded_For_Body
;
6907 -- Start of processing for Use_One_Type;
6910 -- It is the type determined by the subtype mark (8.4(8)) whose
6911 -- operations become potentially use-visible.
6913 T
:= Base_Type
(Entity
(Id
));
6915 -- Either the type itself is used, the package where it is declared
6916 -- is in use or the entity is declared in the current package, thus
6921 or else In_Use
(Scope
(T
))
6922 or else Scope
(T
) = Current_Scope
;
6924 Set_Redundant_Use
(Id
,
6925 Is_Known_Used
or else Is_Potentially_Use_Visible
(T
));
6927 if In_Open_Scopes
(Scope
(T
)) then
6930 -- A limited view cannot appear in a use_type clause. However, an
6931 -- access type whose designated type is limited has the flag but
6932 -- is not itself a limited view unless we only have a limited view
6933 -- of its enclosing package.
6935 elsif From_With_Type
(T
)
6936 and then From_With_Type
(Scope
(T
))
6939 ("incomplete type from limited view "
6940 & "cannot appear in use clause", Id
);
6942 -- If the subtype mark designates a subtype in a different package,
6943 -- we have to check that the parent type is visible, otherwise the
6944 -- use type clause is a noop. Not clear how to do that???
6946 elsif not Redundant_Use
(Id
) then
6948 Op_List
:= Collect_Primitive_Operations
(T
);
6950 Elmt
:= First_Elmt
(Op_List
);
6951 while Present
(Elmt
) loop
6952 if (Nkind
(Node
(Elmt
)) = N_Defining_Operator_Symbol
6953 or else Chars
(Node
(Elmt
)) in Any_Operator_Name
)
6954 and then not Is_Hidden
(Node
(Elmt
))
6956 Set_Is_Potentially_Use_Visible
(Node
(Elmt
));
6963 -- If warning on redundant constructs, check for unnecessary WITH
6965 if Warn_On_Redundant_Constructs
6966 and then Is_Known_Used
6968 -- with P; with P; use P;
6969 -- package P is package X is package body X is
6970 -- type T ... use P.T;
6972 -- The compilation unit is the body of X. GNAT first compiles the
6973 -- spec of X, then procedes to the body. At that point P is marked
6974 -- as use visible. The analysis then reinstalls the spec along with
6975 -- its context. The use clause P.T is now recognized as redundant,
6976 -- but in the wrong context. Do not emit a warning in such cases.
6978 and then not Spec_Reloaded_For_Body
6980 -- The type already has a use clause
6984 ("& is already use-visible through previous use type clause?",
6987 -- The package where T is declared is already used
6989 elsif In_Use
(Scope
(T
)) then
6990 Error_Msg_Sloc
:= Sloc
(Current_Use_Clause
(Scope
(T
)));
6992 ("& is already use-visible through package use clause #?",
6995 -- The current scope is the package where T is declared
6998 Error_Msg_Node_2
:= Scope
(T
);
7000 ("& is already use-visible inside package &?", Id
, Id
);
7009 procedure Write_Info
is
7010 Id
: Entity_Id
:= First_Entity
(Current_Scope
);
7013 -- No point in dumping standard entities
7015 if Current_Scope
= Standard_Standard
then
7019 Write_Str
("========================================================");
7021 Write_Str
(" Defined Entities in ");
7022 Write_Name
(Chars
(Current_Scope
));
7024 Write_Str
("========================================================");
7028 Write_Str
("-- none --");
7032 while Present
(Id
) loop
7033 Write_Entity_Info
(Id
, " ");
7038 if Scope
(Current_Scope
) = Standard_Standard
then
7040 -- Print information on the current unit itself
7042 Write_Entity_Info
(Current_Scope
, " ");
7052 procedure Write_Scopes
is
7055 for J
in reverse 1 .. Scope_Stack
.Last
loop
7056 S
:= Scope_Stack
.Table
(J
).Entity
;
7057 Write_Int
(Int
(S
));
7058 Write_Str
(" === ");
7059 Write_Name
(Chars
(S
));