1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Util
; use Exp_Util
;
33 with Fname
; use Fname
;
34 with Freeze
; use Freeze
;
36 with Lib
.Load
; use Lib
.Load
;
37 with Lib
.Xref
; use Lib
.Xref
;
38 with Namet
; use Namet
;
39 with Nlists
; use Nlists
;
40 with Nmake
; use Nmake
;
42 with Output
; use Output
;
43 with Restrict
; use Restrict
;
44 with Rident
; use Rident
;
45 with Rtsfind
; use Rtsfind
;
47 with Sem_Cat
; use Sem_Cat
;
48 with Sem_Ch3
; use Sem_Ch3
;
49 with Sem_Ch4
; use Sem_Ch4
;
50 with Sem_Ch6
; use Sem_Ch6
;
51 with Sem_Ch12
; use Sem_Ch12
;
52 with Sem_Disp
; use Sem_Disp
;
53 with Sem_Dist
; use Sem_Dist
;
54 with Sem_Res
; use Sem_Res
;
55 with Sem_Util
; use Sem_Util
;
56 with Sem_Type
; use Sem_Type
;
57 with Stand
; use Stand
;
58 with Sinfo
; use Sinfo
;
59 with Sinfo
.CN
; use Sinfo
.CN
;
60 with Snames
; use Snames
;
61 with Style
; use Style
;
63 with Tbuild
; use Tbuild
;
64 with Uintp
; use Uintp
;
66 with GNAT
.Spelling_Checker
; use GNAT
.Spelling_Checker
;
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
232 -- stub, 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
238 -- of the subunit, but without reinitializing the names table, nor the
239 -- scope stack (i.e. standard is not pushed on the stack). In this fashion
240 -- the context of the subunit is added to the context of the parent, and
241 -- the subunit is compiled in the correct environment. Note that in the
242 -- course of processing the context of a subunit, Standard will appear
243 -- twice on the scope stack: once for the parent of the subunit, and
244 -- once for the unit in the context clause being compiled. However, the
245 -- two sets of entities are not linked by homonym chains, so that the
246 -- compilation of any context unit happens in a fresh visibility
249 -------------------------------
250 -- Processing of USE Clauses --
251 -------------------------------
253 -- Every defining occurrence has a flag indicating if it is potentially use
254 -- visible. Resolution of simple names examines this flag. The processing
255 -- of use clauses consists in setting this flag on all visible entities
256 -- defined in the corresponding package. On exit from the scope of the use
257 -- clause, the corresponding flag must be reset. However, a package may
258 -- appear in several nested use clauses (pathological but legal, alas!)
259 -- which forces us to use a slightly more involved scheme:
261 -- a) The defining occurrence for a package holds a flag -In_Use- to
262 -- indicate that it is currently in the scope of a use clause. If a
263 -- redundant use clause is encountered, then the corresponding occurrence
264 -- of the package name is flagged -Redundant_Use-.
266 -- b) On exit from a scope, the use clauses in its declarative part are
267 -- scanned. The visibility flag is reset in all entities declared in
268 -- package named in a use clause, as long as the package is not flagged
269 -- as being in a redundant use clause (in which case the outer use
270 -- clause is still in effect, and the direct visibility of its entities
271 -- must be retained).
273 -- Note that entities are not removed from their homonym chains on exit
274 -- from the package specification. A subsequent use clause does not need
275 -- to rechain the visible entities, but only to establish their direct
278 -----------------------------------
279 -- Handling private declarations --
280 -----------------------------------
282 -- The principle that each entity has a single defining occurrence clashes
283 -- with the presence of two separate definitions for private types: the
284 -- first is the private type declaration, and second is the full type
285 -- declaration. It is important that all references to the type point to
286 -- the same defining occurrence, namely the first one. To enforce the two
287 -- separate views of the entity, the corresponding information is swapped
288 -- between the two declarations. Outside of the package, the defining
289 -- occurrence only contains the private declaration information, while in
290 -- the private part and the body of the package the defining occurrence
291 -- contains the full declaration. To simplify the swap, the defining
292 -- occurrence that currently holds the private declaration points to the
293 -- full declaration. During semantic processing the defining occurrence
294 -- also points to a list of private dependents, that is to say access
295 -- types or composite types whose designated types or component types are
296 -- subtypes or derived types of the private type in question. After the
297 -- full declaration has been seen, the private dependents are updated to
298 -- indicate that they have full definitions.
300 ------------------------------------
301 -- Handling of Undefined Messages --
302 ------------------------------------
304 -- In normal mode, only the first use of an undefined identifier generates
305 -- a message. The table Urefs is used to record error messages that have
306 -- been issued so that second and subsequent ones do not generate further
307 -- messages. However, the second reference causes text to be added to the
308 -- original undefined message noting "(more references follow)". The
309 -- full error list option (-gnatf) forces messages to be generated for
310 -- every reference and disconnects the use of this table.
312 type Uref_Entry
is record
314 -- Node for identifier for which original message was posted. The
315 -- Chars field of this identifier is used to detect later references
316 -- to the same identifier.
319 -- Records error message Id of original undefined message. Reset to
320 -- No_Error_Msg after the second occurrence, where it is used to add
321 -- text to the original message as described above.
324 -- Set if the message is not visible rather than undefined
327 -- Records location of error message. Used to make sure that we do
328 -- not consider a, b : undefined as two separate instances, which
329 -- would otherwise happen, since the parser converts this sequence
330 -- to a : undefined; b : undefined.
334 package Urefs
is new Table
.Table
(
335 Table_Component_Type
=> Uref_Entry
,
336 Table_Index_Type
=> Nat
,
337 Table_Low_Bound
=> 1,
339 Table_Increment
=> 100,
340 Table_Name
=> "Urefs");
342 Candidate_Renaming
: Entity_Id
;
343 -- Holds a candidate interpretation that appears in a subprogram renaming
344 -- declaration and does not match the given specification, but matches at
345 -- least on the first formal. Allows better error message when given
346 -- specification omits defaulted parameters, a common error.
348 -----------------------
349 -- Local Subprograms --
350 -----------------------
352 procedure Analyze_Generic_Renaming
355 -- Common processing for all three kinds of generic renaming declarations.
356 -- Enter new name and indicate that it renames the generic unit.
358 procedure Analyze_Renamed_Character
362 -- Renamed entity is given by a character literal, which must belong
363 -- to the return type of the new entity. Is_Body indicates whether the
364 -- declaration is a renaming_as_body. If the original declaration has
365 -- already been frozen (because of an intervening body, e.g.) the body of
366 -- the function must be built now. The same applies to the following
367 -- various renaming procedures.
369 procedure Analyze_Renamed_Dereference
373 -- Renamed entity is given by an explicit dereference. Prefix must be a
374 -- conformant access_to_subprogram type.
376 procedure Analyze_Renamed_Entry
380 -- If the renamed entity in a subprogram renaming is an entry or protected
381 -- subprogram, build a body for the new entity whose only statement is a
382 -- call to the renamed entity.
384 procedure Analyze_Renamed_Family_Member
388 -- Used when the renamed entity is an indexed component. The prefix must
389 -- denote an entry family.
391 function Applicable_Use
(Pack_Name
: Node_Id
) return Boolean;
392 -- Common code to Use_One_Package and Set_Use, to determine whether
393 -- use clause must be processed. Pack_Name is an entity name that
394 -- references the package in question.
396 procedure Attribute_Renaming
(N
: Node_Id
);
397 -- Analyze renaming of attribute as function. The renaming declaration N
398 -- is rewritten as a function body that returns the attribute reference
399 -- applied to the formals of the function.
401 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
);
402 -- A renaming_as_body may occur after the entity of the original decla-
403 -- ration has been frozen. In that case, the body of the new entity must
404 -- be built now, because the usual mechanism of building the renamed
405 -- body at the point of freezing will not work. Subp is the subprogram
406 -- for which N provides the Renaming_As_Body.
408 procedure Check_In_Previous_With_Clause
411 -- N is a use_package clause and Nam the package name, or N is a use_type
412 -- clause and Nam is the prefix of the type name. In either case, verify
413 -- that the package is visible at that point in the context: either it
414 -- appears in a previous with_clause, or because it is a fully qualified
415 -- name and the root ancestor appears in a previous with_clause.
417 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
);
418 -- Verify that the entity in a renaming declaration that is a library unit
419 -- is itself a library unit and not a nested unit or subunit. Also check
420 -- that if the renaming is a child unit of a generic parent, then the
421 -- renamed unit must also be a child unit of that parent. Finally, verify
422 -- that a renamed generic unit is not an implicit child declared within
423 -- an instance of the parent.
425 procedure Chain_Use_Clause
(N
: Node_Id
);
426 -- Chain use clause onto list of uses clauses headed by First_Use_Clause
427 -- in the top scope table entry.
429 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean;
430 -- Find a type derived from Character or Wide_Character in the prefix of N.
431 -- Used to resolved qualified names whose selector is a character literal.
433 function Has_Private_With
(E
: Entity_Id
) return Boolean;
434 -- Ada 2005 (AI-262): Determines if the current compilation unit has a
437 procedure Find_Expanded_Name
(N
: Node_Id
);
438 -- Selected component is known to be expanded name. Verify legality
439 -- of selector given the scope denoted by prefix.
441 function Find_Renamed_Entity
445 Is_Actual
: Boolean := False) return Entity_Id
;
446 -- Find the renamed entity that corresponds to the given parameter profile
447 -- in a subprogram renaming declaration. The renamed entity may be an
448 -- operator, a subprogram, an entry, or a protected operation. Is_Actual
449 -- indicates that the renaming is the one generated for an actual subpro-
450 -- gram in an instance, for which special visibility checks apply.
452 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean;
453 -- N is an expanded name whose selector is an operator name (eg P."+").
454 -- A declarative part contains an implicit declaration of an operator
455 -- if it has a declaration of a type to which one of the predefined
456 -- operators apply. The existence of this routine is an artifact of
457 -- our implementation: a more straightforward but more space-consuming
458 -- choice would be to make all inherited operators explicit in the
461 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
);
462 -- A subprogram defined by a renaming declaration inherits the parameter
463 -- profile of the renamed entity. The subtypes given in the subprogram
464 -- specification are discarded and replaced with those of the renamed
465 -- subprogram, which are then used to recheck the default values.
467 function Is_Appropriate_For_Record
(T
: Entity_Id
) return Boolean;
468 -- Prefix is appropriate for record if it is of a record type, or
469 -- an access to such.
471 function Is_Appropriate_For_Entry_Prefix
(T
: Entity_Id
) return Boolean;
472 -- True if it is of a task type, a protected type, or else an access
473 -- to one of these types.
475 procedure Premature_Usage
(N
: Node_Id
);
476 -- Diagnose usage of an entity before it is visible
478 procedure Use_One_Package
(P
: Entity_Id
; N
: Node_Id
);
479 -- Make visible entities declared in package P potentially use-visible
480 -- in the current context. Also used in the analysis of subunits, when
481 -- re-installing use clauses of parent units. N is the use_clause that
482 -- names P (and possibly other packages).
484 procedure Use_One_Type
(Id
: Node_Id
);
485 -- Id is the subtype mark from a use type clause. This procedure makes
486 -- the primitive operators of the type potentially use-visible.
488 procedure Write_Info
;
489 -- Write debugging information on entities declared in current scope
491 procedure Write_Scopes
;
492 pragma Warnings
(Off
, Write_Scopes
);
493 -- Debugging information: dump all entities on scope stack
495 --------------------------------
496 -- Analyze_Exception_Renaming --
497 --------------------------------
499 -- The language only allows a single identifier, but the tree holds
500 -- an identifier list. The parser has already issued an error message
501 -- if there is more than one element in the list.
503 procedure Analyze_Exception_Renaming
(N
: Node_Id
) is
504 Id
: constant Node_Id
:= Defining_Identifier
(N
);
505 Nam
: constant Node_Id
:= Name
(N
);
511 Set_Ekind
(Id
, E_Exception
);
512 Set_Exception_Code
(Id
, Uint_0
);
513 Set_Etype
(Id
, Standard_Exception_Type
);
514 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
516 if not Is_Entity_Name
(Nam
) or else
517 Ekind
(Entity
(Nam
)) /= E_Exception
519 Error_Msg_N
("invalid exception name in renaming", Nam
);
521 if Present
(Renamed_Object
(Entity
(Nam
))) then
522 Set_Renamed_Object
(Id
, Renamed_Object
(Entity
(Nam
)));
524 Set_Renamed_Object
(Id
, Entity
(Nam
));
527 end Analyze_Exception_Renaming
;
529 ---------------------------
530 -- Analyze_Expanded_Name --
531 ---------------------------
533 procedure Analyze_Expanded_Name
(N
: Node_Id
) is
535 -- If the entity pointer is already set, this is an internal node, or
536 -- a node that is analyzed more than once, after a tree modification.
537 -- In such a case there is no resolution to perform, just set the type.
538 -- For completeness, analyze prefix as well.
540 if Present
(Entity
(N
)) then
541 if Is_Type
(Entity
(N
)) then
542 Set_Etype
(N
, Entity
(N
));
544 Set_Etype
(N
, Etype
(Entity
(N
)));
547 Analyze
(Prefix
(N
));
550 Find_Expanded_Name
(N
);
552 end Analyze_Expanded_Name
;
554 ---------------------------------------
555 -- Analyze_Generic_Function_Renaming --
556 ---------------------------------------
558 procedure Analyze_Generic_Function_Renaming
(N
: Node_Id
) is
560 Analyze_Generic_Renaming
(N
, E_Generic_Function
);
561 end Analyze_Generic_Function_Renaming
;
563 --------------------------------------
564 -- Analyze_Generic_Package_Renaming --
565 --------------------------------------
567 procedure Analyze_Generic_Package_Renaming
(N
: Node_Id
) is
569 -- Apply the Text_IO Kludge here, since we may be renaming
570 -- one of the subpackages of Text_IO, then join common routine.
572 Text_IO_Kludge
(Name
(N
));
574 Analyze_Generic_Renaming
(N
, E_Generic_Package
);
575 end Analyze_Generic_Package_Renaming
;
577 ----------------------------------------
578 -- Analyze_Generic_Procedure_Renaming --
579 ----------------------------------------
581 procedure Analyze_Generic_Procedure_Renaming
(N
: Node_Id
) is
583 Analyze_Generic_Renaming
(N
, E_Generic_Procedure
);
584 end Analyze_Generic_Procedure_Renaming
;
586 ------------------------------
587 -- Analyze_Generic_Renaming --
588 ------------------------------
590 procedure Analyze_Generic_Renaming
594 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
596 Inst
: Boolean := False; -- prevent junk warning
599 if Name
(N
) = Error
then
603 Generate_Definition
(New_P
);
605 if Current_Scope
/= Standard_Standard
then
606 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
609 if Nkind
(Name
(N
)) = N_Selected_Component
then
610 Check_Generic_Child_Unit
(Name
(N
), Inst
);
615 if not Is_Entity_Name
(Name
(N
)) then
616 Error_Msg_N
("expect entity name in renaming declaration", Name
(N
));
619 Old_P
:= Entity
(Name
(N
));
623 Set_Ekind
(New_P
, K
);
625 if Etype
(Old_P
) = Any_Type
then
628 elsif Ekind
(Old_P
) /= K
then
629 Error_Msg_N
("invalid generic unit name", Name
(N
));
632 if Present
(Renamed_Object
(Old_P
)) then
633 Set_Renamed_Object
(New_P
, Renamed_Object
(Old_P
));
635 Set_Renamed_Object
(New_P
, Old_P
);
638 Set_Etype
(New_P
, Etype
(Old_P
));
639 Set_Has_Completion
(New_P
);
641 if In_Open_Scopes
(Old_P
) then
642 Error_Msg_N
("within its scope, generic denotes its instance", N
);
645 Check_Library_Unit_Renaming
(N
, Old_P
);
648 end Analyze_Generic_Renaming
;
650 -----------------------------
651 -- Analyze_Object_Renaming --
652 -----------------------------
654 procedure Analyze_Object_Renaming
(N
: Node_Id
) is
655 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
657 Nam
: constant Node_Id
:= Name
(N
);
666 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
669 -- The renaming of a component that depends on a discriminant
670 -- requires an actual subtype, because in subsequent use of the object
671 -- Gigi will be unable to locate the actual bounds. This explicit step
672 -- is required when the renaming is generated in removing side effects
673 -- of an already-analyzed expression.
675 if Nkind
(Nam
) = N_Selected_Component
676 and then Analyzed
(Nam
)
679 Dec
:= Build_Actual_Subtype_Of_Component
(Etype
(Nam
), Nam
);
681 if Present
(Dec
) then
682 Insert_Action
(N
, Dec
);
683 T
:= Defining_Identifier
(Dec
);
687 elsif Present
(Subtype_Mark
(N
)) then
688 Find_Type
(Subtype_Mark
(N
));
689 T
:= Entity
(Subtype_Mark
(N
));
690 Analyze_And_Resolve
(Nam
, T
);
692 -- Ada 2005 (AI-230/AI-254): Access renaming
694 else pragma Assert
(Present
(Access_Definition
(N
)));
695 T
:= Access_Definition
697 N
=> Access_Definition
(N
));
699 Analyze_And_Resolve
(Nam
, T
);
701 -- Ada 2005 (AI-231): "In the case where the type is defined by an
702 -- access_definition, the renamed entity shall be of an access-to-
703 -- constant type if and only if the access_definition defines an
704 -- access-to-constant type" ARM 8.5.1(4)
706 if Constant_Present
(Access_Definition
(N
))
707 and then not Is_Access_Constant
(Etype
(Nam
))
709 Error_Msg_N
("(Ada 2005): the renamed object is not "
710 & "access-to-constant ('R'M 8.5.1(6))", N
);
712 elsif Null_Exclusion_Present
(Access_Definition
(N
)) then
713 Error_Msg_N
("(Ada 2005): null-excluding attribute ignored "
714 & "('R'M 8.5.1(6))?", N
);
718 -- An object renaming requires an exact match of the type;
719 -- class-wide matching is not allowed.
721 if Is_Class_Wide_Type
(T
)
722 and then Base_Type
(Etype
(Nam
)) /= Base_Type
(T
)
728 Set_Ekind
(Id
, E_Variable
);
729 Init_Size_Align
(Id
);
731 if T
= Any_Type
or else Etype
(Nam
) = Any_Type
then
734 -- Verify that the renamed entity is an object or a function call.
735 -- It may have been rewritten in several ways.
737 elsif Is_Object_Reference
(Nam
) then
738 if Comes_From_Source
(N
)
739 and then Is_Dependent_Component_Of_Mutable_Object
(Nam
)
742 ("illegal renaming of discriminant-dependent component", Nam
);
747 -- A static function call may have been folded into a literal
749 elsif Nkind
(Original_Node
(Nam
)) = N_Function_Call
751 -- When expansion is disabled, attribute reference is not
752 -- rewritten as function call. Otherwise it may be rewritten
753 -- as a conversion, so check original node.
755 or else (Nkind
(Original_Node
(Nam
)) = N_Attribute_Reference
756 and then Is_Function_Attribute_Name
757 (Attribute_Name
(Original_Node
(Nam
))))
759 -- Weird but legal, equivalent to renaming a function call
761 or else (Is_Entity_Name
(Nam
)
762 and then Ekind
(Entity
(Nam
)) = E_Enumeration_Literal
)
764 or else (Nkind
(Nam
) = N_Type_Conversion
765 and then Is_Tagged_Type
(Entity
(Subtype_Mark
(Nam
))))
770 if Nkind
(Nam
) = N_Type_Conversion
then
772 ("renaming of conversion only allowed for tagged types", Nam
);
775 Error_Msg_N
("expect object name in renaming", Nam
);
781 if not Is_Variable
(Nam
) then
782 Set_Ekind
(Id
, E_Constant
);
783 Set_Never_Set_In_Source
(Id
, True);
784 Set_Is_True_Constant
(Id
, True);
787 Set_Renamed_Object
(Id
, Nam
);
788 end Analyze_Object_Renaming
;
790 ------------------------------
791 -- Analyze_Package_Renaming --
792 ------------------------------
794 procedure Analyze_Package_Renaming
(N
: Node_Id
) is
795 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
800 if Name
(N
) = Error
then
804 -- Apply Text_IO kludge here, since we may be renaming one of
805 -- the children of Text_IO
807 Text_IO_Kludge
(Name
(N
));
809 if Current_Scope
/= Standard_Standard
then
810 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
815 if Is_Entity_Name
(Name
(N
)) then
816 Old_P
:= Entity
(Name
(N
));
821 if Etype
(Old_P
) = Any_Type
then
823 ("expect package name in renaming", Name
(N
));
825 -- Ada 2005 (AI-50217): Limited withed packages can not be renamed
827 elsif Ekind
(Old_P
) = E_Package
828 and then From_With_Type
(Old_P
)
831 ("limited withed package cannot be renamed", Name
(N
));
833 elsif Ekind
(Old_P
) /= E_Package
834 and then not (Ekind
(Old_P
) = E_Generic_Package
835 and then In_Open_Scopes
(Old_P
))
837 if Ekind
(Old_P
) = E_Generic_Package
then
839 ("generic package cannot be renamed as a package", Name
(N
));
841 Error_Msg_Sloc
:= Sloc
(Old_P
);
843 ("expect package name in renaming, found& declared#",
847 -- Set basic attributes to minimize cascaded errors
849 Set_Ekind
(New_P
, E_Package
);
850 Set_Etype
(New_P
, Standard_Void_Type
);
853 -- Entities in the old package are accessible through the
854 -- renaming entity. The simplest implementation is to have
855 -- both packages share the entity list.
857 Set_Ekind
(New_P
, E_Package
);
858 Set_Etype
(New_P
, Standard_Void_Type
);
860 if Present
(Renamed_Object
(Old_P
)) then
861 Set_Renamed_Object
(New_P
, Renamed_Object
(Old_P
));
863 Set_Renamed_Object
(New_P
, Old_P
);
866 Set_Has_Completion
(New_P
);
868 Set_First_Entity
(New_P
, First_Entity
(Old_P
));
869 Set_Last_Entity
(New_P
, Last_Entity
(Old_P
));
870 Set_First_Private_Entity
(New_P
, First_Private_Entity
(Old_P
));
871 Check_Library_Unit_Renaming
(N
, Old_P
);
872 Generate_Reference
(Old_P
, Name
(N
));
874 -- If this is the renaming declaration of a package instantiation
875 -- within itself, it is the declaration that ends the list of actuals
876 -- for the instantiation. At this point, the subtypes that rename
877 -- the actuals are flagged as generic, to avoid spurious ambiguities
878 -- if the actuals for two distinct formals happen to coincide. If
879 -- the actual is a private type, the subtype has a private completion
880 -- that is flagged in the same fashion.
882 -- Resolution is identical to what is was in the original generic.
883 -- On exit from the generic instance, these are turned into regular
884 -- subtypes again, so they are compatible with types in their class.
886 if not Is_Generic_Instance
(Old_P
) then
889 Spec
:= Specification
(Unit_Declaration_Node
(Old_P
));
892 if Nkind
(Spec
) = N_Package_Specification
893 and then Present
(Generic_Parent
(Spec
))
894 and then Old_P
= Current_Scope
895 and then Chars
(New_P
) = Chars
(Generic_Parent
(Spec
))
898 E
: Entity_Id
:= First_Entity
(Old_P
);
904 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
906 Set_Is_Generic_Actual_Type
(E
);
908 if Is_Private_Type
(E
)
909 and then Present
(Full_View
(E
))
911 Set_Is_Generic_Actual_Type
(Full_View
(E
));
921 end Analyze_Package_Renaming
;
923 -------------------------------
924 -- Analyze_Renamed_Character --
925 -------------------------------
927 procedure Analyze_Renamed_Character
932 C
: constant Node_Id
:= Name
(N
);
935 if Ekind
(New_S
) = E_Function
then
936 Resolve
(C
, Etype
(New_S
));
939 Check_Frozen_Renaming
(N
, New_S
);
943 Error_Msg_N
("character literal can only be renamed as function", N
);
945 end Analyze_Renamed_Character
;
947 ---------------------------------
948 -- Analyze_Renamed_Dereference --
949 ---------------------------------
951 procedure Analyze_Renamed_Dereference
956 Nam
: constant Node_Id
:= Name
(N
);
957 P
: constant Node_Id
:= Prefix
(Nam
);
963 if not Is_Overloaded
(P
) then
964 if Ekind
(Etype
(Nam
)) /= E_Subprogram_Type
965 or else not Type_Conformant
(Etype
(Nam
), New_S
) then
966 Error_Msg_N
("designated type does not match specification", P
);
975 Get_First_Interp
(Nam
, Ind
, It
);
977 while Present
(It
.Nam
) loop
979 if Ekind
(It
.Nam
) = E_Subprogram_Type
980 and then Type_Conformant
(It
.Nam
, New_S
) then
982 if Typ
/= Any_Id
then
983 Error_Msg_N
("ambiguous renaming", P
);
990 Get_Next_Interp
(Ind
, It
);
993 if Typ
= Any_Type
then
994 Error_Msg_N
("designated type does not match specification", P
);
999 Check_Frozen_Renaming
(N
, New_S
);
1003 end Analyze_Renamed_Dereference
;
1005 ---------------------------
1006 -- Analyze_Renamed_Entry --
1007 ---------------------------
1009 procedure Analyze_Renamed_Entry
1014 Nam
: constant Node_Id
:= Name
(N
);
1015 Sel
: constant Node_Id
:= Selector_Name
(Nam
);
1019 if Entity
(Sel
) = Any_Id
then
1021 -- Selector is undefined on prefix. Error emitted already
1023 Set_Has_Completion
(New_S
);
1027 -- Otherwise, find renamed entity, and build body of New_S as a call
1030 Old_S
:= Find_Renamed_Entity
(N
, Selector_Name
(Nam
), New_S
);
1032 if Old_S
= Any_Id
then
1033 Error_Msg_N
(" no subprogram or entry matches specification", N
);
1036 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1037 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1038 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1041 Inherit_Renamed_Profile
(New_S
, Old_S
);
1044 Set_Convention
(New_S
, Convention
(Old_S
));
1045 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1048 Check_Frozen_Renaming
(N
, New_S
);
1050 end Analyze_Renamed_Entry
;
1052 -----------------------------------
1053 -- Analyze_Renamed_Family_Member --
1054 -----------------------------------
1056 procedure Analyze_Renamed_Family_Member
1061 Nam
: constant Node_Id
:= Name
(N
);
1062 P
: constant Node_Id
:= Prefix
(Nam
);
1066 if (Is_Entity_Name
(P
) and then Ekind
(Entity
(P
)) = E_Entry_Family
)
1067 or else (Nkind
(P
) = N_Selected_Component
1069 Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
)
1071 if Is_Entity_Name
(P
) then
1072 Old_S
:= Entity
(P
);
1074 Old_S
:= Entity
(Selector_Name
(P
));
1077 if not Entity_Matches_Spec
(Old_S
, New_S
) then
1078 Error_Msg_N
("entry family does not match specification", N
);
1081 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1082 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1083 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1086 Error_Msg_N
("no entry family matches specification", N
);
1089 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1092 Check_Frozen_Renaming
(N
, New_S
);
1094 end Analyze_Renamed_Family_Member
;
1096 ---------------------------------
1097 -- Analyze_Subprogram_Renaming --
1098 ---------------------------------
1100 procedure Analyze_Subprogram_Renaming
(N
: Node_Id
) is
1101 Spec
: constant Node_Id
:= Specification
(N
);
1102 Save_AV
: constant Ada_Version_Type
:= Ada_Version
;
1103 Nam
: constant Node_Id
:= Name
(N
);
1105 Old_S
: Entity_Id
:= Empty
;
1106 Rename_Spec
: Entity_Id
;
1107 Is_Actual
: Boolean := False;
1108 Inst_Node
: Node_Id
:= Empty
;
1110 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
;
1111 -- Find renamed entity when the declaration is a renaming_as_body
1112 -- and the renamed entity may itself be a renaming_as_body. Used to
1113 -- enforce rule that a renaming_as_body is illegal if the declaration
1114 -- occurs before the subprogram it completes is frozen, and renaming
1115 -- indirectly renames the subprogram itself.(Defect Report 8652/0027).
1117 -------------------------
1118 -- Original_Subprogram --
1119 -------------------------
1121 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
is
1122 Orig_Decl
: Node_Id
;
1123 Orig_Subp
: Entity_Id
;
1126 -- First case: renamed entity is itself a renaming
1128 if Present
(Alias
(Subp
)) then
1129 return Alias
(Subp
);
1132 Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
1134 (Corresponding_Body
(Unit_Declaration_Node
(Subp
)))
1136 -- Check if renamed entity is a renaming_as_body
1139 Unit_Declaration_Node
1140 (Corresponding_Body
(Unit_Declaration_Node
(Subp
)));
1142 if Nkind
(Orig_Decl
) = N_Subprogram_Renaming_Declaration
then
1143 Orig_Subp
:= Entity
(Name
(Orig_Decl
));
1145 if Orig_Subp
= Rename_Spec
then
1147 -- Circularity detected
1152 return (Original_Subprogram
(Orig_Subp
));
1160 end Original_Subprogram
;
1162 -- Start of processing for Analyze_Subprogram_Renaming
1165 -- We must test for the attribute renaming case before the Analyze
1166 -- call because otherwise Sem_Attr will complain that the attribute
1167 -- is missing an argument when it is analyzed.
1169 if Nkind
(Nam
) = N_Attribute_Reference
then
1170 Attribute_Renaming
(N
);
1174 -- Check whether this declaration corresponds to the instantiation
1175 -- of a formal subprogram.
1177 -- If this is an instantiation, the corresponding actual is frozen
1178 -- and error messages can be made more precise. If this is a default
1179 -- subprogram, the entity is already established in the generic, and
1180 -- is not retrieved by visibility. If it is a default with a box, the
1181 -- candidate interpretations, if any, have been collected when building
1182 -- the renaming declaration. If overloaded, the proper interpretation
1183 -- is determined in Find_Renamed_Entity. If the entity is an operator,
1184 -- Find_Renamed_Entity applies additional visibility checks.
1186 if Present
(Corresponding_Formal_Spec
(N
)) then
1188 Inst_Node
:= Unit_Declaration_Node
(Corresponding_Formal_Spec
(N
));
1190 if Is_Entity_Name
(Nam
)
1191 and then Present
(Entity
(Nam
))
1192 and then not Comes_From_Source
(Nam
)
1193 and then not Is_Overloaded
(Nam
)
1195 Old_S
:= Entity
(Nam
);
1196 New_S
:= Analyze_Subprogram_Specification
(Spec
);
1200 if Ekind
(Entity
(Nam
)) = E_Operator
then
1204 if Box_Present
(Inst_Node
) then
1205 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
1207 -- If there is an immediately visible homonym of the operator
1208 -- and the declaration has a default, this is worth a warning
1209 -- because the user probably did not intend to get the pre-
1210 -- defined operator, visible in the generic declaration.
1211 -- To find if there is an intended candidate, analyze the
1212 -- renaming again in the current context.
1214 elsif Scope
(Old_S
) = Standard_Standard
1215 and then Present
(Default_Name
(Inst_Node
))
1218 Decl
: constant Node_Id
:= New_Copy_Tree
(N
);
1222 Set_Entity
(Name
(Decl
), Empty
);
1223 Analyze
(Name
(Decl
));
1225 Find_Renamed_Entity
(Decl
, Name
(Decl
), New_S
, True);
1228 and then In_Open_Scopes
(Scope
(Hidden
))
1229 and then Is_Immediately_Visible
(Hidden
)
1230 and then Comes_From_Source
(Hidden
)
1231 and then Hidden
/= Old_S
1233 Error_Msg_Sloc
:= Sloc
(Hidden
);
1234 Error_Msg_N
("?default subprogram is resolved " &
1235 "in the generic declaration " &
1236 "('R'M 12.6(17))", N
);
1237 Error_Msg_NE
("\?and will not use & #", N
, Hidden
);
1245 New_S
:= Analyze_Subprogram_Specification
(Spec
);
1249 -- Renamed entity must be analyzed first, to avoid being hidden by
1250 -- new name (which might be the same in a generic instance).
1254 -- The renaming defines a new overloaded entity, which is analyzed
1255 -- like a subprogram declaration.
1257 New_S
:= Analyze_Subprogram_Specification
(Spec
);
1260 if Current_Scope
/= Standard_Standard
then
1261 Set_Is_Pure
(New_S
, Is_Pure
(Current_Scope
));
1264 Rename_Spec
:= Find_Corresponding_Spec
(N
);
1266 if Present
(Rename_Spec
) then
1268 -- Renaming_As_Body. Renaming declaration is the completion of
1269 -- the declaration of Rename_Spec. We will build an actual body
1270 -- for it at the freezing point.
1272 Set_Corresponding_Spec
(N
, Rename_Spec
);
1273 Set_Corresponding_Body
(Unit_Declaration_Node
(Rename_Spec
), New_S
);
1275 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
1276 Error_Msg_N
("(Ada 83) renaming cannot serve as a body", N
);
1279 Set_Convention
(New_S
, Convention
(Rename_Spec
));
1280 Check_Fully_Conformant
(New_S
, Rename_Spec
);
1281 Set_Public_Status
(New_S
);
1283 -- Indicate that the entity in the declaration functions like
1284 -- the corresponding body, and is not a new entity. The body will
1285 -- be constructed later at the freeze point, so indicate that
1286 -- the completion has not been seen yet.
1288 Set_Ekind
(New_S
, E_Subprogram_Body
);
1289 New_S
:= Rename_Spec
;
1290 Set_Has_Completion
(Rename_Spec
, False);
1293 Generate_Definition
(New_S
);
1294 New_Overloaded_Entity
(New_S
);
1295 if Is_Entity_Name
(Nam
)
1296 and then Is_Intrinsic_Subprogram
(Entity
(Nam
))
1300 Check_Delayed_Subprogram
(New_S
);
1304 -- There is no need for elaboration checks on the new entity, which
1305 -- may be called before the next freezing point where the body will
1306 -- appear. Elaboration checks refer to the real entity, not the one
1307 -- created by the renaming declaration.
1309 Set_Kill_Elaboration_Checks
(New_S
, True);
1311 if Etype
(Nam
) = Any_Type
then
1312 Set_Has_Completion
(New_S
);
1315 elsif Nkind
(Nam
) = N_Selected_Component
then
1317 -- Renamed entity is an entry or protected subprogram. For those
1318 -- cases an explicit body is built (at the point of freezing of
1319 -- this entity) that contains a call to the renamed entity.
1321 Analyze_Renamed_Entry
(N
, New_S
, Present
(Rename_Spec
));
1324 elsif Nkind
(Nam
) = N_Explicit_Dereference
then
1326 -- Renamed entity is designated by access_to_subprogram expression.
1327 -- Must build body to encapsulate call, as in the entry case.
1329 Analyze_Renamed_Dereference
(N
, New_S
, Present
(Rename_Spec
));
1332 elsif Nkind
(Nam
) = N_Indexed_Component
then
1333 Analyze_Renamed_Family_Member
(N
, New_S
, Present
(Rename_Spec
));
1336 elsif Nkind
(Nam
) = N_Character_Literal
then
1337 Analyze_Renamed_Character
(N
, New_S
, Present
(Rename_Spec
));
1340 elsif (not Is_Entity_Name
(Nam
)
1341 and then Nkind
(Nam
) /= N_Operator_Symbol
)
1342 or else not Is_Overloadable
(Entity
(Nam
))
1344 Error_Msg_N
("expect valid subprogram name in renaming", N
);
1349 -- Most common case: subprogram renames subprogram. No body is
1350 -- generated in this case, so we must indicate that the declaration
1351 -- is complete as is.
1353 if No
(Rename_Spec
) then
1354 Set_Has_Completion
(New_S
);
1357 -- Find the renamed entity that matches the given specification.
1358 -- Disable Ada_83 because there is no requirement of full conformance
1359 -- between renamed entity and new entity, even though the same circuit
1362 Ada_Version
:= Ada_Version_Type
'Max (Ada_Version
, Ada_95
);
1365 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
1368 if Old_S
/= Any_Id
then
1370 and then From_Default
(N
)
1372 -- This is an implicit reference to the default actual
1374 Generate_Reference
(Old_S
, Nam
, Typ
=> 'i', Force
=> True);
1376 Generate_Reference
(Old_S
, Nam
);
1379 -- For a renaming-as-body, require subtype conformance,
1380 -- but if the declaration being completed has not been
1381 -- frozen, then inherit the convention of the renamed
1382 -- subprogram prior to checking conformance (unless the
1383 -- renaming has an explicit convention established; the
1384 -- rule stated in the RM doesn't seem to address this ???).
1386 if Present
(Rename_Spec
) then
1387 Generate_Reference
(Rename_Spec
, Defining_Entity
(Spec
), 'b');
1388 Style
.Check_Identifier
(Defining_Entity
(Spec
), Rename_Spec
);
1390 if not Is_Frozen
(Rename_Spec
) then
1391 if not Has_Convention_Pragma
(Rename_Spec
) then
1392 Set_Convention
(New_S
, Convention
(Old_S
));
1395 if Ekind
(Old_S
) /= E_Operator
then
1396 Check_Mode_Conformant
(New_S
, Old_S
, Spec
);
1399 if Original_Subprogram
(Old_S
) = Rename_Spec
then
1400 Error_Msg_N
("unfrozen subprogram cannot rename itself ", N
);
1403 Check_Subtype_Conformant
(New_S
, Old_S
, Spec
);
1406 Check_Frozen_Renaming
(N
, Rename_Spec
);
1408 -- Check explicitly that renamed entity is not intrinsic, because
1409 -- in in a generic the renamed body is not built. In this case,
1410 -- the renaming_as_body is a completion.
1412 if Inside_A_Generic
then
1413 if Is_Frozen
(Rename_Spec
)
1414 and then Is_Intrinsic_Subprogram
(Old_S
)
1417 ("subprogram in renaming_as_body cannot be intrinsic",
1421 Set_Has_Completion
(Rename_Spec
);
1424 elsif Ekind
(Old_S
) /= E_Operator
then
1425 Check_Mode_Conformant
(New_S
, Old_S
);
1428 and then Error_Posted
(New_S
)
1430 Error_Msg_NE
("invalid actual subprogram: & #!", N
, Old_S
);
1434 if No
(Rename_Spec
) then
1436 -- The parameter profile of the new entity is that of the renamed
1437 -- entity: the subtypes given in the specification are irrelevant.
1439 Inherit_Renamed_Profile
(New_S
, Old_S
);
1441 -- A call to the subprogram is transformed into a call to the
1442 -- renamed entity. This is transitive if the renamed entity is
1443 -- itself a renaming.
1445 if Present
(Alias
(Old_S
)) then
1446 Set_Alias
(New_S
, Alias
(Old_S
));
1448 Set_Alias
(New_S
, Old_S
);
1451 -- Note that we do not set Is_Intrinsic_Subprogram if we have
1452 -- a renaming as body, since the entity in this case is not an
1453 -- intrinsic (it calls an intrinsic, but we have a real body
1454 -- for this call, and it is in this body that the required
1455 -- intrinsic processing will take place).
1457 -- Also, if this is a renaming of inequality, the renamed
1458 -- operator is intrinsic, but what matters is the corresponding
1459 -- equality operator, which may be user-defined.
1461 Set_Is_Intrinsic_Subprogram
1463 Is_Intrinsic_Subprogram
(Old_S
)
1465 (Chars
(Old_S
) /= Name_Op_Ne
1466 or else Ekind
(Old_S
) = E_Operator
1468 Is_Intrinsic_Subprogram
1469 (Corresponding_Equality
(Old_S
))));
1471 if Ekind
(Alias
(New_S
)) = E_Operator
then
1472 Set_Has_Delayed_Freeze
(New_S
, False);
1475 -- If the renaming corresponds to an association for an abstract
1476 -- formal subprogram, then various attributes must be set to
1477 -- indicate that the renaming is an abstract dispatching operation
1478 -- with a controlling type.
1481 and then Is_Abstract
(Corresponding_Formal_Spec
(N
))
1483 -- Mark the renaming as abstract here, so Find_Dispatching_Type
1484 -- see it as corresponding to a generic association for a
1485 -- formal abstract subprogram
1487 Set_Is_Abstract
(New_S
);
1490 New_S_Ctrl_Type
: constant Entity_Id
:=
1491 Find_Dispatching_Type
(New_S
);
1492 Old_S_Ctrl_Type
: constant Entity_Id
:=
1493 Find_Dispatching_Type
(Old_S
);
1496 if Old_S_Ctrl_Type
/= New_S_Ctrl_Type
then
1498 ("actual must be dispatching subprogram for type&",
1499 Nam
, New_S_Ctrl_Type
);
1502 Set_Is_Dispatching_Operation
(New_S
);
1503 Check_Controlling_Formals
(New_S_Ctrl_Type
, New_S
);
1505 -- In the case where the actual in the formal subprogram
1506 -- is itself a formal abstract subprogram association,
1507 -- there's no dispatch table component or position to
1510 if Present
(DTC_Entity
(Old_S
)) then
1511 Set_DTC_Entity
(New_S
, DTC_Entity
(Old_S
));
1512 Set_DT_Position
(New_S
, DT_Position
(Old_S
));
1520 and then (Old_S
= New_S
1521 or else (Nkind
(Nam
) /= N_Expanded_Name
1522 and then Chars
(Old_S
) = Chars
(New_S
)))
1524 Error_Msg_N
("subprogram cannot rename itself", N
);
1527 Set_Convention
(New_S
, Convention
(Old_S
));
1528 Set_Is_Abstract
(New_S
, Is_Abstract
(Old_S
));
1529 Check_Library_Unit_Renaming
(N
, Old_S
);
1531 -- Pathological case: procedure renames entry in the scope of
1532 -- its task. Entry is given by simple name, but body must be built
1533 -- for procedure. Of course if called it will deadlock.
1535 if Ekind
(Old_S
) = E_Entry
then
1536 Set_Has_Completion
(New_S
, False);
1537 Set_Alias
(New_S
, Empty
);
1541 Freeze_Before
(N
, Old_S
);
1542 Set_Has_Delayed_Freeze
(New_S
, False);
1543 Freeze_Before
(N
, New_S
);
1545 -- An abstract subprogram is only allowed as an actual in the case
1546 -- where the formal subprogram is also abstract.
1548 if (Ekind
(Old_S
) = E_Procedure
or else Ekind
(Old_S
) = E_Function
)
1549 and then Is_Abstract
(Old_S
)
1550 and then not Is_Abstract
(Corresponding_Formal_Spec
(N
))
1553 ("abstract subprogram not allowed as generic actual", Nam
);
1558 -- A common error is to assume that implicit operators for types
1559 -- are defined in Standard, or in the scope of a subtype. In those
1560 -- cases where the renamed entity is given with an expanded name,
1561 -- it is worth mentioning that operators for the type are not
1562 -- declared in the scope given by the prefix.
1564 if Nkind
(Nam
) = N_Expanded_Name
1565 and then Nkind
(Selector_Name
(Nam
)) = N_Operator_Symbol
1566 and then Scope
(Entity
(Nam
)) = Standard_Standard
1569 T
: constant Entity_Id
:=
1570 Base_Type
(Etype
(First_Formal
(New_S
)));
1573 Error_Msg_Node_2
:= Prefix
(Nam
);
1575 ("operator for type& is not declared in&", Prefix
(Nam
), T
);
1580 ("no visible subprogram matches the specification for&",
1584 if Present
(Candidate_Renaming
) then
1590 F1
:= First_Formal
(Candidate_Renaming
);
1591 F2
:= First_Formal
(New_S
);
1593 while Present
(F1
) and then Present
(F2
) loop
1598 if Present
(F1
) and then Present
(Default_Value
(F1
)) then
1599 if Present
(Next_Formal
(F1
)) then
1601 ("\missing specification for &" &
1602 " and other formals with defaults", Spec
, F1
);
1605 ("\missing specification for &", Spec
, F1
);
1612 Ada_Version
:= Save_AV
;
1613 end Analyze_Subprogram_Renaming
;
1615 -------------------------
1616 -- Analyze_Use_Package --
1617 -------------------------
1619 -- Resolve the package names in the use clause, and make all the visible
1620 -- entities defined in the package potentially use-visible. If the package
1621 -- is already in use from a previous use clause, its visible entities are
1622 -- already use-visible. In that case, mark the occurrence as a redundant
1623 -- use. If the package is an open scope, i.e. if the use clause occurs
1624 -- within the package itself, ignore it.
1626 procedure Analyze_Use_Package
(N
: Node_Id
) is
1627 Pack_Name
: Node_Id
;
1630 -- Start of processing for Analyze_Use_Package
1633 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
1635 -- Use clause is not allowed in a spec of a predefined package
1636 -- declaration except that packages whose file name starts a-n
1637 -- are OK (these are children of Ada.Numerics, and such packages
1638 -- are never loaded by Rtsfind).
1640 if Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
1641 and then Name_Buffer
(1 .. 3) /= "a-n"
1643 Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
1645 Error_Msg_N
("use clause not allowed in predefined spec", N
);
1648 -- Chain clause to list of use clauses in current scope
1650 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
1651 Chain_Use_Clause
(N
);
1654 -- Loop through package names to identify referenced packages
1656 Pack_Name
:= First
(Names
(N
));
1658 while Present
(Pack_Name
) loop
1659 Analyze
(Pack_Name
);
1661 if Nkind
(Parent
(N
)) = N_Compilation_Unit
1662 and then Nkind
(Pack_Name
) = N_Expanded_Name
1665 Pref
: Node_Id
:= Prefix
(Pack_Name
);
1668 while Nkind
(Pref
) = N_Expanded_Name
loop
1669 Pref
:= Prefix
(Pref
);
1672 if Entity
(Pref
) = Standard_Standard
then
1674 ("predefined package Standard cannot appear"
1675 & " in a context clause", Pref
);
1683 -- Loop through package names to mark all entities as potentially
1686 Pack_Name
:= First
(Names
(N
));
1688 while Present
(Pack_Name
) loop
1690 if Is_Entity_Name
(Pack_Name
) then
1691 Pack
:= Entity
(Pack_Name
);
1693 if Ekind
(Pack
) /= E_Package
1694 and then Etype
(Pack
) /= Any_Type
1696 if Ekind
(Pack
) = E_Generic_Package
then
1698 ("a generic package is not allowed in a use clause",
1701 Error_Msg_N
("& is not a usable package", Pack_Name
);
1705 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
1706 Check_In_Previous_With_Clause
(N
, Pack_Name
);
1709 if Applicable_Use
(Pack_Name
) then
1710 Use_One_Package
(Pack
, N
);
1718 end Analyze_Use_Package
;
1720 ----------------------
1721 -- Analyze_Use_Type --
1722 ----------------------
1724 procedure Analyze_Use_Type
(N
: Node_Id
) is
1728 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
1730 -- Chain clause to list of use clauses in current scope
1732 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
1733 Chain_Use_Clause
(N
);
1736 Id
:= First
(Subtype_Marks
(N
));
1738 while Present
(Id
) loop
1741 if Entity
(Id
) /= Any_Type
then
1744 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
1745 if Nkind
(Id
) = N_Identifier
then
1746 Error_Msg_N
("Type is not directly visible", Id
);
1748 elsif Is_Child_Unit
(Scope
(Entity
(Id
)))
1749 and then Scope
(Entity
(Id
)) /= System_Aux_Id
1751 Check_In_Previous_With_Clause
(N
, Prefix
(Id
));
1758 end Analyze_Use_Type
;
1760 --------------------
1761 -- Applicable_Use --
1762 --------------------
1764 function Applicable_Use
(Pack_Name
: Node_Id
) return Boolean is
1765 Pack
: constant Entity_Id
:= Entity
(Pack_Name
);
1768 if In_Open_Scopes
(Pack
) then
1771 elsif In_Use
(Pack
) then
1772 Set_Redundant_Use
(Pack_Name
, True);
1775 elsif Present
(Renamed_Object
(Pack
))
1776 and then In_Use
(Renamed_Object
(Pack
))
1778 Set_Redundant_Use
(Pack_Name
, True);
1786 ------------------------
1787 -- Attribute_Renaming --
1788 ------------------------
1790 procedure Attribute_Renaming
(N
: Node_Id
) is
1791 Loc
: constant Source_Ptr
:= Sloc
(N
);
1792 Nam
: constant Node_Id
:= Name
(N
);
1793 Spec
: constant Node_Id
:= Specification
(N
);
1794 New_S
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
1795 Aname
: constant Name_Id
:= Attribute_Name
(Nam
);
1797 Form_Num
: Nat
:= 0;
1798 Expr_List
: List_Id
:= No_List
;
1800 Attr_Node
: Node_Id
;
1801 Body_Node
: Node_Id
;
1802 Param_Spec
: Node_Id
;
1805 Generate_Definition
(New_S
);
1807 -- This procedure is called in the context of subprogram renaming,
1808 -- and thus the attribute must be one that is a subprogram. All of
1809 -- those have at least one formal parameter, with the singular
1810 -- exception of AST_Entry (which is a real oddity, it is odd that
1811 -- this can be renamed at all!)
1813 if not Is_Non_Empty_List
(Parameter_Specifications
(Spec
)) then
1814 if Aname
/= Name_AST_Entry
then
1816 ("subprogram renaming an attribute must have formals", N
);
1821 Param_Spec
:= First
(Parameter_Specifications
(Spec
));
1823 while Present
(Param_Spec
) loop
1824 Form_Num
:= Form_Num
+ 1;
1826 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
1827 Find_Type
(Parameter_Type
(Param_Spec
));
1829 -- The profile of the new entity denotes the base type (s) of
1830 -- the types given in the specification. For access parameters
1831 -- there are no subtypes involved.
1833 Rewrite
(Parameter_Type
(Param_Spec
),
1835 (Base_Type
(Entity
(Parameter_Type
(Param_Spec
))), Loc
));
1838 if No
(Expr_List
) then
1839 Expr_List
:= New_List
;
1842 Append_To
(Expr_List
,
1843 Make_Identifier
(Loc
,
1844 Chars
=> Chars
(Defining_Identifier
(Param_Spec
))));
1846 -- The expressions in the attribute reference are not freeze
1847 -- points. Neither is the attribute as a whole, see below.
1849 Set_Must_Not_Freeze
(Last
(Expr_List
));
1854 -- Immediate error if too many formals. Other mismatches in numbers
1855 -- of number of types of parameters are detected when we analyze the
1856 -- body of the subprogram that we construct.
1858 if Form_Num
> 2 then
1859 Error_Msg_N
("too many formals for attribute", N
);
1861 -- Error if the attribute reference has expressions that look
1862 -- like formal parameters.
1864 elsif Present
(Expressions
(Nam
)) then
1865 Error_Msg_N
("illegal expressions in attribute reference", Nam
);
1868 Aname
= Name_Compose
or else
1869 Aname
= Name_Exponent
or else
1870 Aname
= Name_Leading_Part
or else
1871 Aname
= Name_Pos
or else
1872 Aname
= Name_Round
or else
1873 Aname
= Name_Scaling
or else
1876 if Nkind
(N
) = N_Subprogram_Renaming_Declaration
1877 and then Present
(Corresponding_Formal_Spec
(N
))
1880 ("generic actual cannot be attribute involving universal type",
1884 ("attribute involving a universal type cannot be renamed",
1889 -- AST_Entry is an odd case. It doesn't really make much sense to
1890 -- allow it to be renamed, but that's the DEC rule, so we have to
1891 -- do it right. The point is that the AST_Entry call should be made
1892 -- now, and what the function will return is the returned value.
1894 -- Note that there is no Expr_List in this case anyway
1896 if Aname
= Name_AST_Entry
then
1903 Ent
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
1906 Make_Object_Declaration
(Loc
,
1907 Defining_Identifier
=> Ent
,
1908 Object_Definition
=>
1909 New_Occurrence_Of
(RTE
(RE_AST_Handler
), Loc
),
1911 Constant_Present
=> True);
1913 Set_Assignment_OK
(Decl
, True);
1914 Insert_Action
(N
, Decl
);
1915 Attr_Node
:= Make_Identifier
(Loc
, Chars
(Ent
));
1918 -- For all other attributes, we rewrite the attribute node to have
1919 -- a list of expressions corresponding to the subprogram formals.
1920 -- A renaming declaration is not a freeze point, and the analysis of
1921 -- the attribute reference should not freeze the type of the prefix.
1925 Make_Attribute_Reference
(Loc
,
1926 Prefix
=> Prefix
(Nam
),
1927 Attribute_Name
=> Aname
,
1928 Expressions
=> Expr_List
);
1930 Set_Must_Not_Freeze
(Attr_Node
);
1931 Set_Must_Not_Freeze
(Prefix
(Nam
));
1934 -- Case of renaming a function
1936 if Nkind
(Spec
) = N_Function_Specification
then
1938 if Is_Procedure_Attribute_Name
(Aname
) then
1939 Error_Msg_N
("attribute can only be renamed as procedure", Nam
);
1943 Find_Type
(Subtype_Mark
(Spec
));
1944 Rewrite
(Subtype_Mark
(Spec
),
1945 New_Reference_To
(Base_Type
(Entity
(Subtype_Mark
(Spec
))), Loc
));
1948 Make_Subprogram_Body
(Loc
,
1949 Specification
=> Spec
,
1950 Declarations
=> New_List
,
1951 Handled_Statement_Sequence
=>
1952 Make_Handled_Sequence_Of_Statements
(Loc
,
1953 Statements
=> New_List
(
1954 Make_Return_Statement
(Loc
,
1955 Expression
=> Attr_Node
))));
1957 -- Case of renaming a procedure
1960 if not Is_Procedure_Attribute_Name
(Aname
) then
1961 Error_Msg_N
("attribute can only be renamed as function", Nam
);
1966 Make_Subprogram_Body
(Loc
,
1967 Specification
=> Spec
,
1968 Declarations
=> New_List
,
1969 Handled_Statement_Sequence
=>
1970 Make_Handled_Sequence_Of_Statements
(Loc
,
1971 Statements
=> New_List
(Attr_Node
)));
1974 Rewrite
(N
, Body_Node
);
1977 if Is_Compilation_Unit
(New_S
) then
1979 ("a library unit can only rename another library unit", N
);
1982 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
1984 -- We suppress elaboration warnings for the resulting entity, since
1985 -- clearly they are not needed, and more particularly, in the case
1986 -- of a generic formal subprogram, the resulting entity can appear
1987 -- after the instantiation itself, and thus look like a bogus case
1988 -- of access before elaboration.
1990 Set_Suppress_Elaboration_Warnings
(New_S
);
1992 end Attribute_Renaming
;
1994 ----------------------
1995 -- Chain_Use_Clause --
1996 ----------------------
1998 procedure Chain_Use_Clause
(N
: Node_Id
) is
2000 Set_Next_Use_Clause
(N
,
2001 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
);
2002 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
:= N
;
2003 end Chain_Use_Clause
;
2005 ---------------------------
2006 -- Check_Frozen_Renaming --
2007 ---------------------------
2009 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
) is
2015 and then not Has_Completion
(Subp
)
2019 (Parent
(Declaration_Node
(Subp
)), Defining_Entity
(N
));
2021 if Is_Entity_Name
(Name
(N
)) then
2022 Old_S
:= Entity
(Name
(N
));
2024 if not Is_Frozen
(Old_S
)
2025 and then Operating_Mode
/= Check_Semantics
2027 Append_Freeze_Action
(Old_S
, B_Node
);
2029 Insert_After
(N
, B_Node
);
2033 if Is_Intrinsic_Subprogram
(Old_S
)
2034 and then not In_Instance
2037 ("subprogram used in renaming_as_body cannot be intrinsic",
2042 Insert_After
(N
, B_Node
);
2046 end Check_Frozen_Renaming
;
2048 -----------------------------------
2049 -- Check_In_Previous_With_Clause --
2050 -----------------------------------
2052 procedure Check_In_Previous_With_Clause
2056 Pack
: constant Entity_Id
:= Entity
(Original_Node
(Nam
));
2061 Item
:= First
(Context_Items
(Parent
(N
)));
2063 while Present
(Item
)
2066 if Nkind
(Item
) = N_With_Clause
2067 and then Entity
(Name
(Item
)) = Pack
2071 -- Find root library unit in with_clause
2073 while Nkind
(Par
) = N_Expanded_Name
loop
2074 Par
:= Prefix
(Par
);
2077 if Is_Child_Unit
(Entity
(Original_Node
(Par
))) then
2079 ("& is not directly visible", Par
, Entity
(Par
));
2088 -- On exit, package is not mentioned in a previous with_clause.
2089 -- Check if its prefix is.
2091 if Nkind
(Nam
) = N_Expanded_Name
then
2092 Check_In_Previous_With_Clause
(N
, Prefix
(Nam
));
2094 elsif Pack
/= Any_Id
then
2095 Error_Msg_NE
("& is not visible", Nam
, Pack
);
2097 end Check_In_Previous_With_Clause
;
2099 ---------------------------------
2100 -- Check_Library_Unit_Renaming --
2101 ---------------------------------
2103 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
) is
2107 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
2110 elsif Scope
(Old_E
) /= Standard_Standard
2111 and then not Is_Child_Unit
(Old_E
)
2113 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
2115 -- Entities defined in Standard (operators and boolean literals) cannot
2116 -- be renamed as library units.
2118 elsif Scope
(Old_E
) = Standard_Standard
2119 and then Sloc
(Old_E
) = Standard_Location
2121 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
2123 elsif Present
(Parent_Spec
(N
))
2124 and then Nkind
(Unit
(Parent_Spec
(N
))) = N_Generic_Package_Declaration
2125 and then not Is_Child_Unit
(Old_E
)
2128 ("renamed unit must be a child unit of generic parent", Name
(N
));
2130 elsif Nkind
(N
) in N_Generic_Renaming_Declaration
2131 and then Nkind
(Name
(N
)) = N_Expanded_Name
2132 and then Is_Generic_Instance
(Entity
(Prefix
(Name
(N
))))
2133 and then Is_Generic_Unit
(Old_E
)
2136 ("renamed generic unit must be a library unit", Name
(N
));
2138 elsif Ekind
(Old_E
) = E_Package
2139 or else Ekind
(Old_E
) = E_Generic_Package
2141 -- Inherit categorization flags
2143 New_E
:= Defining_Entity
(N
);
2144 Set_Is_Pure
(New_E
, Is_Pure
(Old_E
));
2145 Set_Is_Preelaborated
(New_E
, Is_Preelaborated
(Old_E
));
2146 Set_Is_Remote_Call_Interface
(New_E
,
2147 Is_Remote_Call_Interface
(Old_E
));
2148 Set_Is_Remote_Types
(New_E
, Is_Remote_Types
(Old_E
));
2149 Set_Is_Shared_Passive
(New_E
, Is_Shared_Passive
(Old_E
));
2151 end Check_Library_Unit_Renaming
;
2157 procedure End_Scope
is
2163 Id
:= First_Entity
(Current_Scope
);
2165 while Present
(Id
) loop
2166 -- An entity in the current scope is not necessarily the first one
2167 -- on its homonym chain. Find its predecessor if any,
2168 -- If it is an internal entity, it will not be in the visibility
2169 -- chain altogether, and there is nothing to unchain.
2171 if Id
/= Current_Entity
(Id
) then
2172 Prev
:= Current_Entity
(Id
);
2173 while Present
(Prev
)
2174 and then Present
(Homonym
(Prev
))
2175 and then Homonym
(Prev
) /= Id
2177 Prev
:= Homonym
(Prev
);
2180 -- Skip to end of loop if Id is not in the visibility chain
2182 if No
(Prev
) or else Homonym
(Prev
) /= Id
then
2190 Outer
:= Homonym
(Id
);
2191 Set_Is_Immediately_Visible
(Id
, False);
2193 while Present
(Outer
) and then Scope
(Outer
) = Current_Scope
loop
2194 Outer
:= Homonym
(Outer
);
2197 -- Reset homonym link of other entities, but do not modify link
2198 -- between entities in current scope, so that the back-end can have
2199 -- a proper count of local overloadings.
2202 Set_Name_Entity_Id
(Chars
(Id
), Outer
);
2204 elsif Scope
(Prev
) /= Scope
(Id
) then
2205 Set_Homonym
(Prev
, Outer
);
2212 -- If the scope generated freeze actions, place them before the
2213 -- current declaration and analyze them. Type declarations and
2214 -- the bodies of initialization procedures can generate such nodes.
2215 -- We follow the parent chain until we reach a list node, which is
2216 -- the enclosing list of declarations. If the list appears within
2217 -- a protected definition, move freeze nodes outside the protected
2221 (Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
)
2225 L
: constant List_Id
:= Scope_Stack
.Table
2226 (Scope_Stack
.Last
).Pending_Freeze_Actions
;
2229 if Is_Itype
(Current_Scope
) then
2230 Decl
:= Associated_Node_For_Itype
(Current_Scope
);
2232 Decl
:= Parent
(Current_Scope
);
2237 while not (Is_List_Member
(Decl
))
2238 or else Nkind
(Parent
(Decl
)) = N_Protected_Definition
2239 or else Nkind
(Parent
(Decl
)) = N_Task_Definition
2241 Decl
:= Parent
(Decl
);
2244 Insert_List_Before_And_Analyze
(Decl
, L
);
2253 ---------------------
2254 -- End_Use_Clauses --
2255 ---------------------
2257 procedure End_Use_Clauses
(Clause
: Node_Id
) is
2261 -- Remove Use_Type clauses first, because they affect the
2262 -- visibility of operators in subsequent used packages.
2265 while Present
(U
) loop
2266 if Nkind
(U
) = N_Use_Type_Clause
then
2270 Next_Use_Clause
(U
);
2274 while Present
(U
) loop
2275 if Nkind
(U
) = N_Use_Package_Clause
then
2276 End_Use_Package
(U
);
2279 Next_Use_Clause
(U
);
2281 end End_Use_Clauses
;
2283 ---------------------
2284 -- End_Use_Package --
2285 ---------------------
2287 procedure End_Use_Package
(N
: Node_Id
) is
2288 Pack_Name
: Node_Id
;
2293 function Is_Primitive_Operator
2295 F
: Entity_Id
) return Boolean;
2296 -- Check whether Op is a primitive operator of a use-visible type
2298 ---------------------------
2299 -- Is_Primitive_Operator --
2300 ---------------------------
2302 function Is_Primitive_Operator
2304 F
: Entity_Id
) return Boolean
2306 T
: constant Entity_Id
:= Etype
(F
);
2310 and then Scope
(T
) = Scope
(Op
);
2311 end Is_Primitive_Operator
;
2313 -- Start of processing for End_Use_Package
2316 Pack_Name
:= First
(Names
(N
));
2318 while Present
(Pack_Name
) loop
2319 Pack
:= Entity
(Pack_Name
);
2321 if Ekind
(Pack
) = E_Package
then
2323 if In_Open_Scopes
(Pack
) then
2326 elsif not Redundant_Use
(Pack_Name
) then
2327 Set_In_Use
(Pack
, False);
2328 Id
:= First_Entity
(Pack
);
2330 while Present
(Id
) loop
2332 -- Preserve use-visibility of operators that are primitive
2333 -- operators of a type that is use_visible through an active
2336 if Nkind
(Id
) = N_Defining_Operator_Symbol
2338 (Is_Primitive_Operator
(Id
, First_Formal
(Id
))
2340 (Present
(Next_Formal
(First_Formal
(Id
)))
2342 Is_Primitive_Operator
2343 (Id
, Next_Formal
(First_Formal
(Id
)))))
2348 Set_Is_Potentially_Use_Visible
(Id
, False);
2351 if Is_Private_Type
(Id
)
2352 and then Present
(Full_View
(Id
))
2354 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
2360 if Present
(Renamed_Object
(Pack
)) then
2361 Set_In_Use
(Renamed_Object
(Pack
), False);
2364 if Chars
(Pack
) = Name_System
2365 and then Scope
(Pack
) = Standard_Standard
2366 and then Present_System_Aux
2368 Id
:= First_Entity
(System_Aux_Id
);
2370 while Present
(Id
) loop
2371 Set_Is_Potentially_Use_Visible
(Id
, False);
2373 if Is_Private_Type
(Id
)
2374 and then Present
(Full_View
(Id
))
2376 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
2382 Set_In_Use
(System_Aux_Id
, False);
2386 Set_Redundant_Use
(Pack_Name
, False);
2394 if Present
(Hidden_By_Use_Clause
(N
)) then
2395 Elmt
:= First_Elmt
(Hidden_By_Use_Clause
(N
));
2397 while Present
(Elmt
) loop
2398 Set_Is_Immediately_Visible
(Node
(Elmt
));
2402 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
2404 end End_Use_Package
;
2410 procedure End_Use_Type
(N
: Node_Id
) is
2417 Id
:= First
(Subtype_Marks
(N
));
2419 while Present
(Id
) loop
2421 -- A call to rtsfind may occur while analyzing a use_type clause,
2422 -- in which case the type marks are not resolved yet, and there is
2423 -- nothing to remove.
2425 if not Is_Entity_Name
(Id
)
2426 or else No
(Entity
(Id
))
2433 if T
= Any_Type
then
2436 -- Note that the use_Type clause may mention a subtype of the
2437 -- type whose primitive operations have been made visible. Here
2438 -- as elsewhere, it is the base type that matters for visibility.
2440 elsif In_Open_Scopes
(Scope
(Base_Type
(T
))) then
2443 elsif not Redundant_Use
(Id
) then
2444 Set_In_Use
(T
, False);
2445 Set_In_Use
(Base_Type
(T
), False);
2446 Op_List
:= Collect_Primitive_Operations
(T
);
2447 Elmt
:= First_Elmt
(Op_List
);
2449 while Present
(Elmt
) loop
2451 if Nkind
(Node
(Elmt
)) = N_Defining_Operator_Symbol
then
2452 Set_Is_Potentially_Use_Visible
(Node
(Elmt
), False);
2464 ----------------------
2465 -- Find_Direct_Name --
2466 ----------------------
2468 procedure Find_Direct_Name
(N
: Node_Id
) is
2473 Inst
: Entity_Id
:= Empty
;
2474 -- Enclosing instance, if any
2476 Homonyms
: Entity_Id
;
2477 -- Saves start of homonym chain
2479 Nvis_Entity
: Boolean;
2480 -- Set True to indicate that at there is at least one entity on the
2481 -- homonym chain which, while not visible, is visible enough from the
2482 -- user point of view to warrant an error message of "not visible"
2483 -- rather than undefined.
2485 Nvis_Is_Private_Subprg
: Boolean := False;
2486 -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais
2487 -- effect concerning library subprograms has been detected. Used to
2488 -- generate the precise error message.
2490 function From_Actual_Package
(E
: Entity_Id
) return Boolean;
2491 -- Returns true if the entity is declared in a package that is
2492 -- an actual for a formal package of the current instance. Such an
2493 -- entity requires special handling because it may be use-visible
2494 -- but hides directly visible entities defined outside the instance.
2496 function Known_But_Invisible
(E
: Entity_Id
) return Boolean;
2497 -- This function determines whether the entity E (which is not
2498 -- visible) can reasonably be considered to be known to the writer
2499 -- of the reference. This is a heuristic test, used only for the
2500 -- purposes of figuring out whether we prefer to complain that an
2501 -- entity is undefined or invisible (and identify the declaration
2502 -- of the invisible entity in the latter case). The point here is
2503 -- that we don't want to complain that something is invisible and
2504 -- then point to something entirely mysterious to the writer.
2506 procedure Nvis_Messages
;
2507 -- Called if there are no visible entries for N, but there is at least
2508 -- one non-directly visible, or hidden declaration. This procedure
2509 -- outputs an appropriate set of error messages.
2511 procedure Undefined
(Nvis
: Boolean);
2512 -- This function is called if the current node has no corresponding
2513 -- visible entity or entities. The value set in Msg indicates whether
2514 -- an error message was generated (multiple error messages for the
2515 -- same variable are generally suppressed, see body for details).
2516 -- Msg is True if an error message was generated, False if not. This
2517 -- value is used by the caller to determine whether or not to output
2518 -- additional messages where appropriate. The parameter is set False
2519 -- to get the message "X is undefined", and True to get the message
2520 -- "X is not visible".
2522 -------------------------
2523 -- From_Actual_Package --
2524 -------------------------
2526 function From_Actual_Package
(E
: Entity_Id
) return Boolean is
2527 Scop
: constant Entity_Id
:= Scope
(E
);
2531 if not In_Instance
then
2534 Inst
:= Current_Scope
;
2536 while Present
(Inst
)
2537 and then Ekind
(Inst
) /= E_Package
2538 and then not Is_Generic_Instance
(Inst
)
2540 Inst
:= Scope
(Inst
);
2547 Act
:= First_Entity
(Inst
);
2549 while Present
(Act
) loop
2550 if Ekind
(Act
) = E_Package
then
2552 -- Check for end of actuals list
2554 if Renamed_Object
(Act
) = Inst
then
2557 elsif Present
(Associated_Formal_Package
(Act
))
2558 and then Renamed_Object
(Act
) = Scop
2560 -- Entity comes from (instance of) formal package
2575 end From_Actual_Package
;
2577 -------------------------
2578 -- Known_But_Invisible --
2579 -------------------------
2581 function Known_But_Invisible
(E
: Entity_Id
) return Boolean is
2582 Fname
: File_Name_Type
;
2585 -- Entities in Standard are always considered to be known
2587 if Sloc
(E
) <= Standard_Location
then
2590 -- An entity that does not come from source is always considered
2591 -- to be unknown, since it is an artifact of code expansion.
2593 elsif not Comes_From_Source
(E
) then
2596 -- In gnat internal mode, we consider all entities known
2598 elsif GNAT_Mode
then
2602 -- Here we have an entity that is not from package Standard, and
2603 -- which comes from Source. See if it comes from an internal file.
2605 Fname
:= Unit_File_Name
(Get_Source_Unit
(E
));
2607 -- Case of from internal file
2609 if Is_Internal_File_Name
(Fname
) then
2611 -- Private part entities in internal files are never considered
2612 -- to be known to the writer of normal application code.
2614 if Is_Hidden
(E
) then
2618 -- Entities from System packages other than System and
2619 -- System.Storage_Elements are not considered to be known.
2620 -- System.Auxxxx files are also considered known to the user.
2622 -- Should refine this at some point to generally distinguish
2623 -- between known and unknown internal files ???
2625 Get_Name_String
(Fname
);
2630 Name_Buffer
(1 .. 2) /= "s-"
2632 Name_Buffer
(3 .. 8) = "stoele"
2634 Name_Buffer
(3 .. 5) = "aux";
2636 -- If not an internal file, then entity is definitely known,
2637 -- even if it is in a private part (the message generated will
2638 -- note that it is in a private part)
2643 end Known_But_Invisible
;
2649 procedure Nvis_Messages
is
2650 Comp_Unit
: Node_Id
;
2652 Hidden
: Boolean := False;
2656 -- Ada 2005 (AI-262): Generate a precise error concerning the
2657 -- Beaujolais effect that was previously detected
2659 if Nvis_Is_Private_Subprg
then
2661 pragma Assert
(Nkind
(E2
) = N_Defining_Identifier
2662 and then Ekind
(E2
) = E_Function
2663 and then Scope
(E2
) = Standard_Standard
2664 and then Has_Private_With
(E2
));
2666 -- Find the sloc corresponding to the private with'ed unit
2668 Comp_Unit
:= Cunit
(Current_Sem_Unit
);
2669 Item
:= First
(Context_Items
(Comp_Unit
));
2670 Error_Msg_Sloc
:= No_Location
;
2672 while Present
(Item
) loop
2673 if Nkind
(Item
) = N_With_Clause
2674 and then Private_Present
(Item
)
2675 and then Entity
(Name
(Item
)) = E2
2677 Error_Msg_Sloc
:= Sloc
(Item
);
2684 pragma Assert
(Error_Msg_Sloc
/= No_Location
);
2686 Error_Msg_N
("(Ada 2005): hidden by private with clause #", N
);
2690 Undefined
(Nvis
=> True);
2694 -- First loop does hidden declarations
2697 while Present
(Ent
) loop
2698 if Is_Potentially_Use_Visible
(Ent
) then
2701 Error_Msg_N
("multiple use clauses cause hiding!", N
);
2705 Error_Msg_Sloc
:= Sloc
(Ent
);
2706 Error_Msg_N
("hidden declaration#!", N
);
2709 Ent
:= Homonym
(Ent
);
2712 -- If we found hidden declarations, then that's enough, don't
2713 -- bother looking for non-visible declarations as well.
2719 -- Second loop does non-directly visible declarations
2722 while Present
(Ent
) loop
2723 if not Is_Potentially_Use_Visible
(Ent
) then
2725 -- Do not bother the user with unknown entities
2727 if not Known_But_Invisible
(Ent
) then
2731 Error_Msg_Sloc
:= Sloc
(Ent
);
2733 -- Output message noting that there is a non-visible
2734 -- declaration, distinguishing the private part case.
2736 if Is_Hidden
(Ent
) then
2737 Error_Msg_N
("non-visible (private) declaration#!", N
);
2739 Error_Msg_N
("non-visible declaration#!", N
);
2741 if Is_Compilation_Unit
(Ent
)
2743 Nkind
(Parent
(Parent
(N
))) = N_Use_Package_Clause
2746 ("\possibly missing with_clause for&", N
, Ent
);
2750 -- Set entity and its containing package as referenced. We
2751 -- can't be sure of this, but this seems a better choice
2752 -- to avoid unused entity messages.
2754 if Comes_From_Source
(Ent
) then
2755 Set_Referenced
(Ent
);
2756 Set_Referenced
(Cunit_Entity
(Get_Source_Unit
(Ent
)));
2761 Ent
:= Homonym
(Ent
);
2771 procedure Undefined
(Nvis
: Boolean) is
2772 Emsg
: Error_Msg_Id
;
2775 -- We should never find an undefined internal name. If we do, then
2776 -- see if we have previous errors. If so, ignore on the grounds that
2777 -- it is probably a cascaded message (e.g. a block label from a badly
2778 -- formed block). If no previous errors, then we have a real internal
2779 -- error of some kind so raise an exception.
2781 if Is_Internal_Name
(Chars
(N
)) then
2782 if Total_Errors_Detected
/= 0 then
2785 raise Program_Error
;
2789 -- A very specialized error check, if the undefined variable is
2790 -- a case tag, and the case type is an enumeration type, check
2791 -- for a possible misspelling, and if so, modify the identifier
2793 -- Named aggregate should also be handled similarly ???
2795 if Nkind
(N
) = N_Identifier
2796 and then Nkind
(Parent
(N
)) = N_Case_Statement_Alternative
2798 Get_Name_String
(Chars
(N
));
2801 Case_Str
: constant String := Name_Buffer
(1 .. Name_Len
);
2802 Case_Stm
: constant Node_Id
:= Parent
(Parent
(N
));
2803 Case_Typ
: constant Entity_Id
:= Etype
(Expression
(Case_Stm
));
2808 if Is_Enumeration_Type
(Case_Typ
)
2809 and then Case_Typ
/= Standard_Character
2810 and then Case_Typ
/= Standard_Wide_Character
2811 and then Case_Typ
/= Standard_Wide_Wide_Character
2813 Lit
:= First_Literal
(Case_Typ
);
2814 Get_Name_String
(Chars
(Lit
));
2816 if Chars
(Lit
) /= Chars
(N
)
2817 and then Is_Bad_Spelling_Of
2818 (Case_Str
, Name_Buffer
(1 .. Name_Len
))
2820 Error_Msg_Node_2
:= Lit
;
2822 ("& is undefined, assume misspelling of &", N
);
2823 Rewrite
(N
, New_Occurrence_Of
(Lit
, Sloc
(N
)));
2827 Lit
:= Next_Literal
(Lit
);
2832 -- Normal processing
2834 Set_Entity
(N
, Any_Id
);
2835 Set_Etype
(N
, Any_Type
);
2837 -- We use the table Urefs to keep track of entities for which we
2838 -- have issued errors for undefined references. Multiple errors
2839 -- for a single name are normally suppressed, however we modify
2840 -- the error message to alert the programmer to this effect.
2842 for J
in Urefs
.First
.. Urefs
.Last
loop
2843 if Chars
(N
) = Chars
(Urefs
.Table
(J
).Node
) then
2844 if Urefs
.Table
(J
).Err
/= No_Error_Msg
2845 and then Sloc
(N
) /= Urefs
.Table
(J
).Loc
2847 Error_Msg_Node_1
:= Urefs
.Table
(J
).Node
;
2849 if Urefs
.Table
(J
).Nvis
then
2850 Change_Error_Text
(Urefs
.Table
(J
).Err
,
2851 "& is not visible (more references follow)");
2853 Change_Error_Text
(Urefs
.Table
(J
).Err
,
2854 "& is undefined (more references follow)");
2857 Urefs
.Table
(J
).Err
:= No_Error_Msg
;
2860 -- Although we will set Msg False, and thus suppress the
2861 -- message, we also set Error_Posted True, to avoid any
2862 -- cascaded messages resulting from the undefined reference.
2865 Set_Error_Posted
(N
, True);
2870 -- If entry not found, this is first undefined occurrence
2873 Error_Msg_N
("& is not visible!", N
);
2877 Error_Msg_N
("& is undefined!", N
);
2880 -- A very bizarre special check, if the undefined identifier
2881 -- is put or put_line, then add a special error message (since
2882 -- this is a very common error for beginners to make).
2884 if Chars
(N
) = Name_Put
or else Chars
(N
) = Name_Put_Line
then
2885 Error_Msg_N
("\possible missing with of 'Text_'I'O!", N
);
2888 -- Now check for possible misspellings
2890 Get_Name_String
(Chars
(N
));
2894 Ematch
: Entity_Id
:= Empty
;
2896 Last_Name_Id
: constant Name_Id
:=
2897 Name_Id
(Nat
(First_Name_Id
) +
2898 Name_Entries_Count
- 1);
2900 S
: constant String (1 .. Name_Len
) :=
2901 Name_Buffer
(1 .. Name_Len
);
2904 for N
in First_Name_Id
.. Last_Name_Id
loop
2905 E
:= Get_Name_Entity_Id
(N
);
2908 and then (Is_Immediately_Visible
(E
)
2910 Is_Potentially_Use_Visible
(E
))
2912 Get_Name_String
(N
);
2914 if Is_Bad_Spelling_Of
2915 (Name_Buffer
(1 .. Name_Len
), S
)
2923 if Present
(Ematch
) then
2924 Error_Msg_NE
("\possible misspelling of&", N
, Ematch
);
2929 -- Make entry in undefined references table unless the full
2930 -- errors switch is set, in which case by refraining from
2931 -- generating the table entry, we guarantee that we get an
2932 -- error message for every undefined reference.
2934 if not All_Errors_Mode
then
2935 Urefs
.Increment_Last
;
2936 Urefs
.Table
(Urefs
.Last
).Node
:= N
;
2937 Urefs
.Table
(Urefs
.Last
).Err
:= Emsg
;
2938 Urefs
.Table
(Urefs
.Last
).Nvis
:= Nvis
;
2939 Urefs
.Table
(Urefs
.Last
).Loc
:= Sloc
(N
);
2945 -- Start of processing for Find_Direct_Name
2948 -- If the entity pointer is already set, this is an internal node, or
2949 -- a node that is analyzed more than once, after a tree modification.
2950 -- In such a case there is no resolution to perform, just set the type.
2952 if Present
(Entity
(N
)) then
2953 if Is_Type
(Entity
(N
)) then
2954 Set_Etype
(N
, Entity
(N
));
2958 Entyp
: constant Entity_Id
:= Etype
(Entity
(N
));
2961 -- One special case here. If the Etype field is already set,
2962 -- and references the packed array type corresponding to the
2963 -- etype of the referenced entity, then leave it alone. This
2964 -- happens for trees generated from Exp_Pakd, where expressions
2965 -- can be deliberately "mis-typed" to the packed array type.
2967 if Is_Array_Type
(Entyp
)
2968 and then Is_Packed
(Entyp
)
2969 and then Present
(Etype
(N
))
2970 and then Etype
(N
) = Packed_Array_Type
(Entyp
)
2974 -- If not that special case, then just reset the Etype
2977 Set_Etype
(N
, Etype
(Entity
(N
)));
2985 -- Here if Entity pointer was not set, we need full visibility analysis
2986 -- First we generate debugging output if the debug E flag is set.
2988 if Debug_Flag_E
then
2989 Write_Str
("Looking for ");
2990 Write_Name
(Chars
(N
));
2994 Homonyms
:= Current_Entity
(N
);
2995 Nvis_Entity
:= False;
2998 while Present
(E
) loop
3000 -- If entity is immediately visible or potentially use
3001 -- visible, then process the entity and we are done.
3003 if Is_Immediately_Visible
(E
) then
3004 goto Immediately_Visible_Entity
;
3006 elsif Is_Potentially_Use_Visible
(E
) then
3007 goto Potentially_Use_Visible_Entity
;
3009 -- Note if a known but invisible entity encountered
3011 elsif Known_But_Invisible
(E
) then
3012 Nvis_Entity
:= True;
3015 -- Move to next entity in chain and continue search
3020 -- If no entries on homonym chain that were potentially visible,
3021 -- and no entities reasonably considered as non-visible, then
3022 -- we have a plain undefined reference, with no additional
3023 -- explanation required!
3025 if not Nvis_Entity
then
3026 Undefined
(Nvis
=> False);
3028 -- Otherwise there is at least one entry on the homonym chain that
3029 -- is reasonably considered as being known and non-visible.
3037 -- Processing for a potentially use visible entry found. We must search
3038 -- the rest of the homonym chain for two reasons. First, if there is a
3039 -- directly visible entry, then none of the potentially use-visible
3040 -- entities are directly visible (RM 8.4(10)). Second, we need to check
3041 -- for the case of multiple potentially use-visible entries hiding one
3042 -- another and as a result being non-directly visible (RM 8.4(11)).
3044 <<Potentially_Use_Visible_Entity
>> declare
3045 Only_One_Visible
: Boolean := True;
3046 All_Overloadable
: Boolean := Is_Overloadable
(E
);
3051 while Present
(E2
) loop
3052 if Is_Immediately_Visible
(E2
) then
3054 -- If the use-visible entity comes from the actual for a
3055 -- formal package, it hides a directly visible entity from
3056 -- outside the instance.
3058 if From_Actual_Package
(E
)
3059 and then Scope_Depth
(E2
) < Scope_Depth
(Inst
)
3064 goto Immediately_Visible_Entity
;
3067 elsif Is_Potentially_Use_Visible
(E2
) then
3068 Only_One_Visible
:= False;
3069 All_Overloadable
:= All_Overloadable
and Is_Overloadable
(E2
);
3071 -- Ada 2005 (AI-262): Protect against a form of Beujolais effect
3072 -- that can occurr in private_with clauses. Example:
3075 -- private with B; package A is
3076 -- package C is function B return Integer;
3078 -- V1 : Integer := B;
3079 -- private function B return Integer;
3080 -- V2 : Integer := B;
3083 -- V1 resolves to A.B, but V2 resolves to library unit B
3085 elsif Ekind
(E2
) = E_Function
3086 and then Scope
(E2
) = Standard_Standard
3087 and then Has_Private_With
(E2
)
3089 Only_One_Visible
:= False;
3090 All_Overloadable
:= False;
3091 Nvis_Is_Private_Subprg
:= True;
3098 -- On falling through this loop, we have checked that there are no
3099 -- immediately visible entities. Only_One_Visible is set if exactly
3100 -- one potentially use visible entity exists. All_Overloadable is
3101 -- set if all the potentially use visible entities are overloadable.
3102 -- The condition for legality is that either there is one potentially
3103 -- use visible entity, or if there is more than one, then all of them
3104 -- are overloadable.
3106 if Only_One_Visible
or All_Overloadable
then
3109 -- If there is more than one potentially use-visible entity and at
3110 -- least one of them non-overloadable, we have an error (RM 8.4(11).
3111 -- Note that E points to the first such entity on the homonym list.
3112 -- Special case: if one of the entities is declared in an actual
3113 -- package, it was visible in the generic, and takes precedence over
3114 -- other entities that are potentially use-visible. Same if it is
3115 -- declared in a local instantiation of the current instance.
3119 Inst
:= Current_Scope
;
3121 -- Find current instance
3123 while Present
(Inst
)
3124 and then Inst
/= Standard_Standard
3126 if Is_Generic_Instance
(Inst
) then
3130 Inst
:= Scope
(Inst
);
3135 while Present
(E2
) loop
3136 if From_Actual_Package
(E2
)
3138 (Is_Generic_Instance
(Scope
(E2
))
3139 and then Scope_Depth
(Scope
(E2
)) > Scope_Depth
(Inst
))
3152 Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
3154 -- A use-clause in the body of a system file creates a
3155 -- conflict with some entity in a user scope, while rtsfind
3156 -- is active. Keep only the entity that comes from another
3160 while Present
(E2
) loop
3161 if Is_Predefined_File_Name
3162 (Unit_File_Name
(Get_Source_Unit
(Sloc
(E2
))))
3171 -- Entity must exist because predefined unit is correct.
3173 raise Program_Error
;
3182 -- Come here with E set to the first immediately visible entity on
3183 -- the homonym chain. This is the one we want unless there is another
3184 -- immediately visible entity further on in the chain for a more
3185 -- inner scope (RM 8.3(8)).
3187 <<Immediately_Visible_Entity
>> declare
3192 -- Find scope level of initial entity. When compiling through
3193 -- Rtsfind, the previous context is not completely invisible, and
3194 -- an outer entity may appear on the chain, whose scope is below
3195 -- the entry for Standard that delimits the current scope stack.
3196 -- Indicate that the level for this spurious entry is outside of
3197 -- the current scope stack.
3199 Level
:= Scope_Stack
.Last
;
3201 Scop
:= Scope_Stack
.Table
(Level
).Entity
;
3202 exit when Scop
= Scope
(E
);
3204 exit when Scop
= Standard_Standard
;
3207 -- Now search remainder of homonym chain for more inner entry
3208 -- If the entity is Standard itself, it has no scope, and we
3209 -- compare it with the stack entry directly.
3212 while Present
(E2
) loop
3213 if Is_Immediately_Visible
(E2
) then
3214 for J
in Level
+ 1 .. Scope_Stack
.Last
loop
3215 if Scope_Stack
.Table
(J
).Entity
= Scope
(E2
)
3216 or else Scope_Stack
.Table
(J
).Entity
= E2
3228 -- At the end of that loop, E is the innermost immediately
3229 -- visible entity, so we are all set.
3232 -- Come here with entity found, and stored in E
3236 if Comes_From_Source
(N
)
3237 and then Is_Remote_Access_To_Subprogram_Type
(E
)
3238 and then Expander_Active
3239 and then Get_PCS_Name
/= Name_No_DSA
3242 New_Occurrence_Of
(Equivalent_Type
(E
), Sloc
(N
)));
3247 -- Why no Style_Check here???
3252 Set_Etype
(N
, Get_Full_View
(Etype
(E
)));
3255 if Debug_Flag_E
then
3256 Write_Str
(" found ");
3257 Write_Entity_Info
(E
, " ");
3260 -- If the Ekind of the entity is Void, it means that all homonyms
3261 -- are hidden from all visibility (RM 8.3(5,14-20)). However, this
3262 -- test is skipped if the current scope is a record and the name is
3263 -- a pragma argument expression (case of Atomic and Volatile pragmas
3264 -- and possibly other similar pragmas added later, which are allowed
3265 -- to reference components in the current record).
3267 if Ekind
(E
) = E_Void
3269 (not Is_Record_Type
(Current_Scope
)
3270 or else Nkind
(Parent
(N
)) /= N_Pragma_Argument_Association
)
3272 Premature_Usage
(N
);
3274 -- If the entity is overloadable, collect all interpretations
3275 -- of the name for subsequent overload resolution. We optimize
3276 -- a bit here to do this only if we have an overloadable entity
3277 -- that is not on its own on the homonym chain.
3279 elsif Is_Overloadable
(E
)
3280 and then (Present
(Homonym
(E
)) or else Current_Entity
(N
) /= E
)
3282 Collect_Interps
(N
);
3284 -- If no homonyms were visible, the entity is unambiguous
3286 if not Is_Overloaded
(N
) then
3287 Generate_Reference
(E
, N
);
3290 -- Case of non-overloadable entity, set the entity providing that
3291 -- we do not have the case of a discriminant reference within a
3292 -- default expression. Such references are replaced with the
3293 -- corresponding discriminal, which is the formal corresponding to
3294 -- to the discriminant in the initialization procedure.
3297 -- Entity is unambiguous, indicate that it is referenced here
3298 -- One slightly odd case is that we do not want to set the
3299 -- Referenced flag if the entity is a label, and the identifier
3300 -- is the label in the source, since this is not a reference
3301 -- from the point of view of the user
3303 if Nkind
(Parent
(N
)) = N_Label
then
3305 R
: constant Boolean := Referenced
(E
);
3308 Generate_Reference
(E
, N
);
3309 Set_Referenced
(E
, R
);
3312 -- Normal case, not a label. Generate reference
3315 Generate_Reference
(E
, N
);
3318 -- Set Entity, with style check if need be. If this is a
3319 -- discriminant reference, it must be replaced by the
3320 -- corresponding discriminal, that is to say the parameter
3321 -- of the initialization procedure that corresponds to the
3322 -- discriminant. If this replacement is being performed, there
3323 -- is no style check to perform.
3325 -- This replacement must not be done if we are currently
3326 -- processing a generic spec or body, because the discriminal
3327 -- has not been not generated in this case.
3329 if not In_Default_Expression
3330 or else Ekind
(E
) /= E_Discriminant
3331 or else Inside_A_Generic
3333 Set_Entity_With_Style_Check
(N
, E
);
3335 -- The replacement is not done either for a task discriminant that
3336 -- appears in a default expression of an entry parameter. See
3337 -- Expand_Discriminant in exp_ch2 for details on their handling.
3339 elsif Is_Concurrent_Type
(Scope
(E
)) then
3341 P
: Node_Id
:= Parent
(N
);
3345 and then Nkind
(P
) /= N_Parameter_Specification
3346 and then Nkind
(P
) /= N_Component_Declaration
3352 and then Nkind
(P
) = N_Parameter_Specification
3356 Set_Entity
(N
, Discriminal
(E
));
3360 -- Otherwise, this is a discriminant in a context in which
3361 -- it is a reference to the corresponding parameter of the
3362 -- init proc for the enclosing type.
3365 Set_Entity
(N
, Discriminal
(E
));
3369 end Find_Direct_Name
;
3371 ------------------------
3372 -- Find_Expanded_Name --
3373 ------------------------
3375 -- This routine searches the homonym chain of the entity until it finds
3376 -- an entity declared in the scope denoted by the prefix. If the entity
3377 -- is private, it may nevertheless be immediately visible, if we are in
3378 -- the scope of its declaration.
3380 procedure Find_Expanded_Name
(N
: Node_Id
) is
3381 Selector
: constant Node_Id
:= Selector_Name
(N
);
3382 Candidate
: Entity_Id
:= Empty
;
3388 P_Name
:= Entity
(Prefix
(N
));
3391 -- If the prefix is a renamed package, look for the entity
3392 -- in the original package.
3394 if Ekind
(P_Name
) = E_Package
3395 and then Present
(Renamed_Object
(P_Name
))
3397 P_Name
:= Renamed_Object
(P_Name
);
3399 -- Rewrite node with entity field pointing to renamed object
3401 Rewrite
(Prefix
(N
), New_Copy
(Prefix
(N
)));
3402 Set_Entity
(Prefix
(N
), P_Name
);
3404 -- If the prefix is an object of a concurrent type, look for
3405 -- the entity in the associated task or protected type.
3407 elsif Is_Concurrent_Type
(Etype
(P_Name
)) then
3408 P_Name
:= Etype
(P_Name
);
3411 Id
:= Current_Entity
(Selector
);
3413 while Present
(Id
) loop
3415 if Scope
(Id
) = P_Name
then
3418 if Is_Child_Unit
(Id
) then
3419 exit when Is_Visible_Child_Unit
(Id
)
3420 or else Is_Immediately_Visible
(Id
);
3423 exit when not Is_Hidden
(Id
)
3424 or else Is_Immediately_Visible
(Id
);
3432 and then (Ekind
(P_Name
) = E_Procedure
3434 Ekind
(P_Name
) = E_Function
)
3435 and then Is_Generic_Instance
(P_Name
)
3437 -- Expanded name denotes entity in (instance of) generic subprogram.
3438 -- The entity may be in the subprogram instance, or may denote one of
3439 -- the formals, which is declared in the enclosing wrapper package.
3441 P_Name
:= Scope
(P_Name
);
3443 Id
:= Current_Entity
(Selector
);
3444 while Present
(Id
) loop
3445 exit when Scope
(Id
) = P_Name
;
3450 if No
(Id
) or else Chars
(Id
) /= Chars
(Selector
) then
3451 Set_Etype
(N
, Any_Type
);
3453 -- If we are looking for an entity defined in System, try to
3454 -- find it in the child package that may have been provided as
3455 -- an extension to System. The Extend_System pragma will have
3456 -- supplied the name of the extension, which may have to be loaded.
3458 if Chars
(P_Name
) = Name_System
3459 and then Scope
(P_Name
) = Standard_Standard
3460 and then Present
(System_Extend_Unit
)
3461 and then Present_System_Aux
(N
)
3463 Set_Entity
(Prefix
(N
), System_Aux_Id
);
3464 Find_Expanded_Name
(N
);
3467 elsif Nkind
(Selector
) = N_Operator_Symbol
3468 and then Has_Implicit_Operator
(N
)
3470 -- There is an implicit instance of the predefined operator in
3471 -- the given scope. The operator entity is defined in Standard.
3472 -- Has_Implicit_Operator makes the node into an Expanded_Name.
3476 elsif Nkind
(Selector
) = N_Character_Literal
3477 and then Has_Implicit_Character_Literal
(N
)
3479 -- If there is no literal defined in the scope denoted by the
3480 -- prefix, the literal may belong to (a type derived from)
3481 -- Standard_Character, for which we have no explicit literals.
3486 -- If the prefix is a single concurrent object, use its
3487 -- name in the error message, rather than that of the
3490 if Is_Concurrent_Type
(P_Name
)
3491 and then Is_Internal_Name
(Chars
(P_Name
))
3493 Error_Msg_Node_2
:= Entity
(Prefix
(N
));
3495 Error_Msg_Node_2
:= P_Name
;
3498 if P_Name
= System_Aux_Id
then
3499 P_Name
:= Scope
(P_Name
);
3500 Set_Entity
(Prefix
(N
), P_Name
);
3503 if Present
(Candidate
) then
3505 if Is_Child_Unit
(Candidate
) then
3507 ("missing with_clause for child unit &", Selector
);
3509 Error_Msg_NE
("& is not a visible entity of&", N
, Selector
);
3513 -- Within the instantiation of a child unit, the prefix may
3514 -- denote the parent instance, but the selector has the
3515 -- name of the original child. Find whether we are within
3516 -- the corresponding instance, and get the proper entity, which
3517 -- can only be an enclosing scope.
3520 and then In_Open_Scopes
(P_Name
)
3521 and then Is_Generic_Instance
(P_Name
)
3524 S
: Entity_Id
:= Current_Scope
;
3528 for J
in reverse 0 .. Scope_Stack
.Last
loop
3529 S
:= Scope_Stack
.Table
(J
).Entity
;
3531 exit when S
= Standard_Standard
;
3533 if Ekind
(S
) = E_Function
3534 or else Ekind
(S
) = E_Package
3535 or else Ekind
(S
) = E_Procedure
3537 P
:= Generic_Parent
(Specification
3538 (Unit_Declaration_Node
(S
)));
3541 and then Chars
(Scope
(P
)) = Chars
(O_Name
)
3542 and then Chars
(P
) = Chars
(Selector
)
3553 if Chars
(P_Name
) = Name_Ada
3554 and then Scope
(P_Name
) = Standard_Standard
3556 Error_Msg_Node_2
:= Selector
;
3557 Error_Msg_NE
("missing with for `&.&`", N
, P_Name
);
3559 -- If this is a selection from a dummy package, then
3560 -- suppress the error message, of course the entity
3561 -- is missing if the package is missing!
3563 elsif Sloc
(Error_Msg_Node_2
) = No_Location
then
3566 -- Here we have the case of an undefined component
3570 Error_Msg_NE
("& not declared in&", N
, Selector
);
3572 -- Check for misspelling of some entity in prefix
3574 Id
:= First_Entity
(P_Name
);
3575 Get_Name_String
(Chars
(Selector
));
3578 S
: constant String (1 .. Name_Len
) :=
3579 Name_Buffer
(1 .. Name_Len
);
3581 while Present
(Id
) loop
3582 Get_Name_String
(Chars
(Id
));
3583 if Is_Bad_Spelling_Of
3584 (Name_Buffer
(1 .. Name_Len
), S
)
3585 and then not Is_Internal_Name
(Chars
(Id
))
3588 ("possible misspelling of&", Selector
, Id
);
3596 -- Specialize the message if this may be an instantiation
3597 -- of a child unit that was not mentioned in the context.
3599 if Nkind
(Parent
(N
)) = N_Package_Instantiation
3600 and then Is_Generic_Instance
(Entity
(Prefix
(N
)))
3601 and then Is_Compilation_Unit
3602 (Generic_Parent
(Parent
(Entity
(Prefix
(N
)))))
3605 ("\possible missing with clause on child unit&",
3616 if Comes_From_Source
(N
)
3617 and then Is_Remote_Access_To_Subprogram_Type
(Id
)
3618 and then Present
(Equivalent_Type
(Id
))
3620 -- If we are not actually generating distribution code (i.e.
3621 -- the current PCS is the dummy non-distributed version), then
3622 -- the Equivalent_Type will be missing, and Id should be treated
3623 -- as a regular access-to-subprogram type.
3625 Id
:= Equivalent_Type
(Id
);
3626 Set_Chars
(Selector
, Chars
(Id
));
3629 -- Ada 2005 (AI-50217): Check usage of entities in limited withed units
3631 if Ekind
(P_Name
) = E_Package
3632 and then From_With_Type
(P_Name
)
3634 if From_With_Type
(Id
)
3635 or else Is_Type
(Id
)
3636 or else Ekind
(Id
) = E_Package
3641 ("limited withed package can only be used to access "
3642 & " incomplete types",
3647 if Is_Task_Type
(P_Name
)
3648 and then ((Ekind
(Id
) = E_Entry
3649 and then Nkind
(Parent
(N
)) /= N_Attribute_Reference
)
3651 (Ekind
(Id
) = E_Entry_Family
3653 Nkind
(Parent
(Parent
(N
))) /= N_Attribute_Reference
))
3655 -- It is an entry call after all, either to the current task
3656 -- (which will deadlock) or to an enclosing task.
3658 Analyze_Selected_Component
(N
);
3662 Change_Selected_Component_To_Expanded_Name
(N
);
3664 -- Do style check and generate reference, but skip both steps if this
3665 -- entity has homonyms, since we may not have the right homonym set
3666 -- yet. The proper homonym will be set during the resolve phase.
3668 if Has_Homonym
(Id
) then
3671 Set_Entity_With_Style_Check
(N
, Id
);
3672 Generate_Reference
(Id
, N
);
3675 if Is_Type
(Id
) then
3678 Set_Etype
(N
, Get_Full_View
(Etype
(Id
)));
3681 -- If the Ekind of the entity is Void, it means that all homonyms
3682 -- are hidden from all visibility (RM 8.3(5,14-20)).
3684 if Ekind
(Id
) = E_Void
then
3685 Premature_Usage
(N
);
3687 elsif Is_Overloadable
(Id
)
3688 and then Present
(Homonym
(Id
))
3691 H
: Entity_Id
:= Homonym
(Id
);
3694 while Present
(H
) loop
3695 if Scope
(H
) = Scope
(Id
)
3698 or else Is_Immediately_Visible
(H
))
3700 Collect_Interps
(N
);
3707 -- If an extension of System is present, collect possible
3708 -- explicit overloadings declared in the extension.
3710 if Chars
(P_Name
) = Name_System
3711 and then Scope
(P_Name
) = Standard_Standard
3712 and then Present
(System_Extend_Unit
)
3713 and then Present_System_Aux
(N
)
3715 H
:= Current_Entity
(Id
);
3717 while Present
(H
) loop
3718 if Scope
(H
) = System_Aux_Id
then
3719 Add_One_Interp
(N
, H
, Etype
(H
));
3728 if Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
3729 and then Scope
(Id
) /= Standard_Standard
3731 -- In addition to user-defined operators in the given scope,
3732 -- there may be an implicit instance of the predefined
3733 -- operator. The operator (defined in Standard) is found
3734 -- in Has_Implicit_Operator, and added to the interpretations.
3735 -- Procedure Add_One_Interp will determine which hides which.
3737 if Has_Implicit_Operator
(N
) then
3741 end Find_Expanded_Name
;
3743 -------------------------
3744 -- Find_Renamed_Entity --
3745 -------------------------
3747 function Find_Renamed_Entity
3751 Is_Actual
: Boolean := False) return Entity_Id
3754 I1
: Interp_Index
:= 0; -- Suppress junk warnings
3760 function Enclosing_Instance
return Entity_Id
;
3761 -- If the renaming determines the entity for the default of a formal
3762 -- subprogram nested within another instance, choose the innermost
3763 -- candidate. This is because if the formal has a box, and we are within
3764 -- an enclosing instance where some candidate interpretations are local
3765 -- to this enclosing instance, we know that the default was properly
3766 -- resolved when analyzing the generic, so we prefer the local
3767 -- candidates to those that are external. This is not always the case
3768 -- but is a reasonable heuristic on the use of nested generics.
3769 -- The proper solution requires a full renaming model.
3771 function Within
(Inner
, Outer
: Entity_Id
) return Boolean;
3772 -- Determine whether a candidate subprogram is defined within
3773 -- the enclosing instance. If yes, it has precedence over outer
3776 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean;
3777 -- If the renamed entity is an implicit operator, check whether it is
3778 -- visible because its operand type is properly visible. This
3779 -- check applies to explicit renamed entities that appear in the
3780 -- source in a renaming declaration or a formal subprogram instance,
3781 -- but not to default generic actuals with a name.
3783 ------------------------
3784 -- Enclosing_Instance --
3785 ------------------------
3787 function Enclosing_Instance
return Entity_Id
is
3791 if not Is_Generic_Instance
(Current_Scope
)
3792 and then not Is_Actual
3797 S
:= Scope
(Current_Scope
);
3799 while S
/= Standard_Standard
loop
3801 if Is_Generic_Instance
(S
) then
3809 end Enclosing_Instance
;
3811 --------------------------
3812 -- Is_Visible_Operation --
3813 --------------------------
3815 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean is
3821 if Ekind
(Op
) /= E_Operator
3822 or else Scope
(Op
) /= Standard_Standard
3823 or else (In_Instance
3826 or else Present
(Enclosing_Instance
)))
3831 -- For a fixed point type operator, check the resulting type,
3832 -- because it may be a mixed mode integer * fixed operation.
3834 if Present
(Next_Formal
(First_Formal
(New_S
)))
3835 and then Is_Fixed_Point_Type
(Etype
(New_S
))
3837 Typ
:= Etype
(New_S
);
3839 Typ
:= Etype
(First_Formal
(New_S
));
3842 Btyp
:= Base_Type
(Typ
);
3844 if Nkind
(Nam
) /= N_Expanded_Name
then
3845 return (In_Open_Scopes
(Scope
(Btyp
))
3846 or else Is_Potentially_Use_Visible
(Btyp
)
3847 or else In_Use
(Btyp
)
3848 or else In_Use
(Scope
(Btyp
)));
3851 Scop
:= Entity
(Prefix
(Nam
));
3853 if Ekind
(Scop
) = E_Package
3854 and then Present
(Renamed_Object
(Scop
))
3856 Scop
:= Renamed_Object
(Scop
);
3859 -- Operator is visible if prefix of expanded name denotes
3860 -- scope of type, or else type type is defined in System_Aux
3861 -- and the prefix denotes System.
3863 return Scope
(Btyp
) = Scop
3864 or else (Scope
(Btyp
) = System_Aux_Id
3865 and then Scope
(Scope
(Btyp
)) = Scop
);
3868 end Is_Visible_Operation
;
3874 function Within
(Inner
, Outer
: Entity_Id
) return Boolean is
3875 Sc
: Entity_Id
:= Scope
(Inner
);
3878 while Sc
/= Standard_Standard
loop
3890 function Report_Overload
return Entity_Id
;
3891 -- List possible interpretations, and specialize message in the
3892 -- case of a generic actual.
3894 function Report_Overload
return Entity_Id
is
3898 ("ambiguous actual subprogram&, " &
3899 "possible interpretations: ", N
, Nam
);
3902 ("ambiguous subprogram, " &
3903 "possible interpretations: ", N
);
3906 List_Interps
(Nam
, N
);
3908 end Report_Overload
;
3910 -- Start of processing for Find_Renamed_Entry
3914 Candidate_Renaming
:= Empty
;
3916 if not Is_Overloaded
(Nam
) then
3917 if Entity_Matches_Spec
(Entity
(Nam
), New_S
)
3918 and then Is_Visible_Operation
(Entity
(Nam
))
3920 Old_S
:= Entity
(Nam
);
3923 Present
(First_Formal
(Entity
(Nam
)))
3924 and then Present
(First_Formal
(New_S
))
3925 and then (Base_Type
(Etype
(First_Formal
(Entity
(Nam
))))
3926 = Base_Type
(Etype
(First_Formal
(New_S
))))
3928 Candidate_Renaming
:= Entity
(Nam
);
3932 Get_First_Interp
(Nam
, Ind
, It
);
3934 while Present
(It
.Nam
) loop
3936 if Entity_Matches_Spec
(It
.Nam
, New_S
)
3937 and then Is_Visible_Operation
(It
.Nam
)
3939 if Old_S
/= Any_Id
then
3941 -- Note: The call to Disambiguate only happens if a
3942 -- previous interpretation was found, in which case I1
3943 -- has received a value.
3945 It1
:= Disambiguate
(Nam
, I1
, Ind
, Etype
(Old_S
));
3947 if It1
= No_Interp
then
3949 Inst
:= Enclosing_Instance
;
3951 if Present
(Inst
) then
3953 if Within
(It
.Nam
, Inst
) then
3956 elsif Within
(Old_S
, Inst
) then
3960 return Report_Overload
;
3964 return Report_Overload
;
3978 Present
(First_Formal
(It
.Nam
))
3979 and then Present
(First_Formal
(New_S
))
3980 and then (Base_Type
(Etype
(First_Formal
(It
.Nam
)))
3981 = Base_Type
(Etype
(First_Formal
(New_S
))))
3983 Candidate_Renaming
:= It
.Nam
;
3986 Get_Next_Interp
(Ind
, It
);
3989 Set_Entity
(Nam
, Old_S
);
3990 Set_Is_Overloaded
(Nam
, False);
3994 end Find_Renamed_Entity
;
3996 -----------------------------
3997 -- Find_Selected_Component --
3998 -----------------------------
4000 procedure Find_Selected_Component
(N
: Node_Id
) is
4001 P
: constant Node_Id
:= Prefix
(N
);
4004 -- Entity denoted by prefix
4014 if Nkind
(P
) = N_Error
then
4017 -- If the selector already has an entity, the node has been
4018 -- constructed in the course of expansion, and is known to be
4019 -- valid. Do not verify that it is defined for the type (it may
4020 -- be a private component used in the expansion of record equality).
4022 elsif Present
(Entity
(Selector_Name
(N
))) then
4025 or else Etype
(N
) = Any_Type
4028 Sel_Name
: constant Node_Id
:= Selector_Name
(N
);
4029 Selector
: constant Entity_Id
:= Entity
(Sel_Name
);
4033 Set_Etype
(Sel_Name
, Etype
(Selector
));
4035 if not Is_Entity_Name
(P
) then
4039 -- Build an actual subtype except for the first parameter
4040 -- of an init proc, where this actual subtype is by
4041 -- definition incorrect, since the object is uninitialized
4042 -- (and does not even have defined discriminants etc.)
4044 if Is_Entity_Name
(P
)
4045 and then Ekind
(Entity
(P
)) = E_Function
4047 Nam
:= New_Copy
(P
);
4049 if Is_Overloaded
(P
) then
4050 Save_Interps
(P
, Nam
);
4054 Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
4056 Analyze_Selected_Component
(N
);
4059 elsif Ekind
(Selector
) = E_Component
4060 and then (not Is_Entity_Name
(P
)
4061 or else Chars
(Entity
(P
)) /= Name_uInit
)
4064 Build_Actual_Subtype_Of_Component
(
4065 Etype
(Selector
), N
);
4070 if No
(C_Etype
) then
4071 C_Etype
:= Etype
(Selector
);
4073 Insert_Action
(N
, C_Etype
);
4074 C_Etype
:= Defining_Identifier
(C_Etype
);
4077 Set_Etype
(N
, C_Etype
);
4080 -- If this is the name of an entry or protected operation, and
4081 -- the prefix is an access type, insert an explicit dereference,
4082 -- so that entry calls are treated uniformly.
4084 if Is_Access_Type
(Etype
(P
))
4085 and then Is_Concurrent_Type
(Designated_Type
(Etype
(P
)))
4088 New_P
: constant Node_Id
:=
4089 Make_Explicit_Dereference
(Sloc
(P
),
4090 Prefix
=> Relocate_Node
(P
));
4093 Set_Etype
(P
, Designated_Type
(Etype
(Prefix
(P
))));
4097 -- If the selected component appears within a default expression
4098 -- and it has an actual subtype, the pre-analysis has not yet
4099 -- completed its analysis, because Insert_Actions is disabled in
4100 -- that context. Within the init proc of the enclosing type we
4101 -- must complete this analysis, if an actual subtype was created.
4103 elsif Inside_Init_Proc
then
4105 Typ
: constant Entity_Id
:= Etype
(N
);
4106 Decl
: constant Node_Id
:= Declaration_Node
(Typ
);
4109 if Nkind
(Decl
) = N_Subtype_Declaration
4110 and then not Analyzed
(Decl
)
4111 and then Is_List_Member
(Decl
)
4112 and then No
(Parent
(Decl
))
4115 Insert_Action
(N
, Decl
);
4122 elsif Is_Entity_Name
(P
) then
4123 P_Name
:= Entity
(P
);
4125 -- The prefix may denote an enclosing type which is the completion
4126 -- of an incomplete type declaration.
4128 if Is_Type
(P_Name
) then
4129 Set_Entity
(P
, Get_Full_View
(P_Name
));
4130 Set_Etype
(P
, Entity
(P
));
4131 P_Name
:= Entity
(P
);
4134 P_Type
:= Base_Type
(Etype
(P
));
4136 if Debug_Flag_E
then
4137 Write_Str
("Found prefix type to be ");
4138 Write_Entity_Info
(P_Type
, " "); Write_Eol
;
4141 -- First check for components of a record object (not the
4142 -- result of a call, which is handled below).
4144 if Is_Appropriate_For_Record
(P_Type
)
4145 and then not Is_Overloadable
(P_Name
)
4146 and then not Is_Type
(P_Name
)
4148 -- Selected component of record. Type checking will validate
4149 -- name of selector.
4151 Analyze_Selected_Component
(N
);
4153 elsif Is_Appropriate_For_Entry_Prefix
(P_Type
)
4154 and then not In_Open_Scopes
(P_Name
)
4155 and then (not Is_Concurrent_Type
(Etype
(P_Name
))
4156 or else not In_Open_Scopes
(Etype
(P_Name
)))
4158 -- Call to protected operation or entry. Type checking is
4159 -- needed on the prefix.
4161 Analyze_Selected_Component
(N
);
4163 elsif (In_Open_Scopes
(P_Name
)
4164 and then Ekind
(P_Name
) /= E_Void
4165 and then not Is_Overloadable
(P_Name
))
4166 or else (Is_Concurrent_Type
(Etype
(P_Name
))
4167 and then In_Open_Scopes
(Etype
(P_Name
)))
4169 -- Prefix denotes an enclosing loop, block, or task, i.e. an
4170 -- enclosing construct that is not a subprogram or accept.
4172 Find_Expanded_Name
(N
);
4174 elsif Ekind
(P_Name
) = E_Package
then
4175 Find_Expanded_Name
(N
);
4177 elsif Is_Overloadable
(P_Name
) then
4179 -- The subprogram may be a renaming (of an enclosing scope) as
4180 -- in the case of the name of the generic within an instantiation.
4182 if (Ekind
(P_Name
) = E_Procedure
4183 or else Ekind
(P_Name
) = E_Function
)
4184 and then Present
(Alias
(P_Name
))
4185 and then Is_Generic_Instance
(Alias
(P_Name
))
4187 P_Name
:= Alias
(P_Name
);
4190 if Is_Overloaded
(P
) then
4192 -- The prefix must resolve to a unique enclosing construct
4195 Found
: Boolean := False;
4200 Get_First_Interp
(P
, Ind
, It
);
4202 while Present
(It
.Nam
) loop
4204 if In_Open_Scopes
(It
.Nam
) then
4207 "prefix must be unique enclosing scope", N
);
4208 Set_Entity
(N
, Any_Id
);
4209 Set_Etype
(N
, Any_Type
);
4218 Get_Next_Interp
(Ind
, It
);
4223 if In_Open_Scopes
(P_Name
) then
4224 Set_Entity
(P
, P_Name
);
4225 Set_Is_Overloaded
(P
, False);
4226 Find_Expanded_Name
(N
);
4229 -- If no interpretation as an expanded name is possible, it
4230 -- must be a selected component of a record returned by a
4231 -- function call. Reformat prefix as a function call, the
4232 -- rest is done by type resolution. If the prefix is a
4233 -- procedure or entry, as is P.X; this is an error.
4235 if Ekind
(P_Name
) /= E_Function
4236 and then (not Is_Overloaded
(P
)
4238 Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
)
4241 -- Prefix may mention a package that is hidden by a local
4242 -- declaration: let the user know. Scan the full homonym
4243 -- chain, the candidate package may be anywhere on it.
4245 if Present
(Homonym
(Current_Entity
(P_Name
))) then
4247 P_Name
:= Current_Entity
(P_Name
);
4249 while Present
(P_Name
) loop
4250 exit when Ekind
(P_Name
) = E_Package
;
4251 P_Name
:= Homonym
(P_Name
);
4254 if Present
(P_Name
) then
4255 Error_Msg_Sloc
:= Sloc
(Entity
(Prefix
(N
)));
4258 ("package& is hidden by declaration#",
4261 Set_Entity
(Prefix
(N
), P_Name
);
4262 Find_Expanded_Name
(N
);
4265 P_Name
:= Entity
(Prefix
(N
));
4270 ("invalid prefix in selected component&", N
, P_Name
);
4271 Change_Selected_Component_To_Expanded_Name
(N
);
4272 Set_Entity
(N
, Any_Id
);
4273 Set_Etype
(N
, Any_Type
);
4276 Nam
:= New_Copy
(P
);
4277 Save_Interps
(P
, Nam
);
4279 Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
4281 Analyze_Selected_Component
(N
);
4285 -- Remaining cases generate various error messages
4288 -- Format node as expanded name, to avoid cascaded errors
4290 Change_Selected_Component_To_Expanded_Name
(N
);
4291 Set_Entity
(N
, Any_Id
);
4292 Set_Etype
(N
, Any_Type
);
4294 -- Issue error message, but avoid this if error issued already.
4295 -- Use identifier of prefix if one is available.
4297 if P_Name
= Any_Id
then
4300 elsif Ekind
(P_Name
) = E_Void
then
4301 Premature_Usage
(P
);
4303 elsif Nkind
(P
) /= N_Attribute_Reference
then
4305 "invalid prefix in selected component&", P
);
4307 if Is_Access_Type
(P_Type
)
4308 and then Ekind
(Designated_Type
(P_Type
)) = E_Incomplete_Type
4311 ("\dereference must not be of an incomplete type " &
4312 "('R'M 3.10.1)", P
);
4317 "invalid prefix in selected component", P
);
4322 -- If prefix is not the name of an entity, it must be an expression,
4323 -- whose type is appropriate for a record. This is determined by
4326 Analyze_Selected_Component
(N
);
4328 end Find_Selected_Component
;
4334 procedure Find_Type
(N
: Node_Id
) is
4344 elsif Nkind
(N
) = N_Attribute_Reference
then
4346 -- Class attribute. This is only valid in Ada 95 mode, but we don't
4347 -- do a check, since the tagged type referenced could only exist if
4348 -- we were in 95 mode when it was declared (or, if we were in Ada
4349 -- 83 mode, then an error message would already have been issued).
4351 if Attribute_Name
(N
) = Name_Class
then
4352 Check_Restriction
(No_Dispatch
, N
);
4353 Find_Type
(Prefix
(N
));
4355 -- Propagate error from bad prefix
4357 if Etype
(Prefix
(N
)) = Any_Type
then
4358 Set_Entity
(N
, Any_Type
);
4359 Set_Etype
(N
, Any_Type
);
4363 T
:= Base_Type
(Entity
(Prefix
(N
)));
4365 -- Case of non-tagged type
4367 if not Is_Tagged_Type
(T
) then
4368 if Ekind
(T
) = E_Incomplete_Type
then
4370 -- It is legal to denote the class type of an incomplete
4371 -- type. The full type will have to be tagged, of course.
4373 Set_Is_Tagged_Type
(T
);
4374 Make_Class_Wide_Type
(T
);
4375 Set_Entity
(N
, Class_Wide_Type
(T
));
4376 Set_Etype
(N
, Class_Wide_Type
(T
));
4378 elsif Ekind
(T
) = E_Private_Type
4379 and then not Is_Generic_Type
(T
)
4380 and then In_Private_Part
(Scope
(T
))
4382 -- The Class attribute can be applied to an untagged
4383 -- private type fulfilled by a tagged type prior to
4384 -- the full type declaration (but only within the
4385 -- parent package's private part). Create the class-wide
4386 -- type now and check that the full type is tagged
4387 -- later during its analysis. Note that we do not
4388 -- mark the private type as tagged, unlike the case
4389 -- of incomplete types, because the type must still
4390 -- appear untagged to outside units.
4392 if not Present
(Class_Wide_Type
(T
)) then
4393 Make_Class_Wide_Type
(T
);
4396 Set_Entity
(N
, Class_Wide_Type
(T
));
4397 Set_Etype
(N
, Class_Wide_Type
(T
));
4400 -- Should we introduce a type Any_Tagged and use
4401 -- Wrong_Type here, it would be a bit more consistent???
4404 ("tagged type required, found}",
4405 Prefix
(N
), First_Subtype
(T
));
4406 Set_Entity
(N
, Any_Type
);
4410 -- Case of tagged type
4413 C
:= Class_Wide_Type
(Entity
(Prefix
(N
)));
4414 Set_Entity_With_Style_Check
(N
, C
);
4415 Generate_Reference
(C
, N
);
4419 -- Base attribute, not allowed in Ada 83
4421 elsif Attribute_Name
(N
) = Name_Base
then
4422 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4424 ("(Ada 83) Base attribute not allowed in subtype mark", N
);
4427 Find_Type
(Prefix
(N
));
4428 Typ
:= Entity
(Prefix
(N
));
4430 if Ada_Version
>= Ada_95
4431 and then not Is_Scalar_Type
(Typ
)
4432 and then not Is_Generic_Type
(Typ
)
4435 ("prefix of Base attribute must be scalar type",
4438 elsif Sloc
(Typ
) = Standard_Location
4439 and then Base_Type
(Typ
) = Typ
4440 and then Warn_On_Redundant_Constructs
4443 ("?redudant attribute, & is its own base type", N
, Typ
);
4446 T
:= Base_Type
(Typ
);
4448 -- Rewrite attribute reference with type itself (see similar
4449 -- processing in Analyze_Attribute, case Base). Preserve
4450 -- prefix if present, for other legality checks.
4452 if Nkind
(Prefix
(N
)) = N_Expanded_Name
then
4454 Make_Expanded_Name
(Sloc
(N
),
4455 Chars
=> Chars
(Entity
(N
)),
4456 Prefix
=> New_Copy
(Prefix
(Prefix
(N
))),
4458 New_Reference_To
(Entity
(N
), Sloc
(N
))));
4462 New_Reference_To
(Entity
(N
), Sloc
(N
)));
4469 -- All other attributes are invalid in a subtype mark
4472 Error_Msg_N
("invalid attribute in subtype mark", N
);
4478 if Is_Entity_Name
(N
) then
4479 T_Name
:= Entity
(N
);
4481 Error_Msg_N
("subtype mark required in this context", N
);
4482 Set_Etype
(N
, Any_Type
);
4486 if T_Name
= Any_Id
or else Etype
(N
) = Any_Type
then
4488 -- Undefined id. Make it into a valid type
4490 Set_Entity
(N
, Any_Type
);
4492 elsif not Is_Type
(T_Name
)
4493 and then T_Name
/= Standard_Void_Type
4495 Error_Msg_Sloc
:= Sloc
(T_Name
);
4496 Error_Msg_N
("subtype mark required in this context", N
);
4497 Error_Msg_NE
("\found & declared#", N
, T_Name
);
4498 Set_Entity
(N
, Any_Type
);
4501 T_Name
:= Get_Full_View
(T_Name
);
4503 if In_Open_Scopes
(T_Name
) then
4504 if Ekind
(Base_Type
(T_Name
)) = E_Task_Type
then
4505 Error_Msg_N
("task type cannot be used as type mark " &
4506 "within its own body", N
);
4508 Error_Msg_N
("type declaration cannot refer to itself", N
);
4511 Set_Etype
(N
, Any_Type
);
4512 Set_Entity
(N
, Any_Type
);
4513 Set_Error_Posted
(T_Name
);
4517 Set_Entity
(N
, T_Name
);
4518 Set_Etype
(N
, T_Name
);
4522 if Present
(Etype
(N
)) and then Comes_From_Source
(N
) then
4523 if Is_Fixed_Point_Type
(Etype
(N
)) then
4524 Check_Restriction
(No_Fixed_Point
, N
);
4525 elsif Is_Floating_Point_Type
(Etype
(N
)) then
4526 Check_Restriction
(No_Floating_Point
, N
);
4535 function Get_Full_View
(T_Name
: Entity_Id
) return Entity_Id
is
4537 if Ekind
(T_Name
) = E_Incomplete_Type
4538 and then Present
(Full_View
(T_Name
))
4540 return Full_View
(T_Name
);
4542 elsif Is_Class_Wide_Type
(T_Name
)
4543 and then Ekind
(Root_Type
(T_Name
)) = E_Incomplete_Type
4544 and then Present
(Full_View
(Root_Type
(T_Name
)))
4546 return Class_Wide_Type
(Full_View
(Root_Type
(T_Name
)));
4553 ------------------------------------
4554 -- Has_Implicit_Character_Literal --
4555 ------------------------------------
4557 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean is
4559 Found
: Boolean := False;
4560 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
4561 Priv_Id
: Entity_Id
:= Empty
;
4564 if Ekind
(P
) = E_Package
4565 and then not In_Open_Scopes
(P
)
4567 Priv_Id
:= First_Private_Entity
(P
);
4570 if P
= Standard_Standard
then
4571 Change_Selected_Component_To_Expanded_Name
(N
);
4572 Rewrite
(N
, Selector_Name
(N
));
4574 Set_Etype
(Original_Node
(N
), Standard_Character
);
4578 Id
:= First_Entity
(P
);
4581 and then Id
/= Priv_Id
4583 if Is_Character_Type
(Id
)
4584 and then (Root_Type
(Id
) = Standard_Character
4585 or else Root_Type
(Id
) = Standard_Wide_Character
4586 or else Root_Type
(Id
) = Standard_Wide_Wide_Character
)
4587 and then Id
= Base_Type
(Id
)
4589 -- We replace the node with the literal itself, resolve as a
4590 -- character, and set the type correctly.
4593 Change_Selected_Component_To_Expanded_Name
(N
);
4594 Rewrite
(N
, Selector_Name
(N
));
4597 Set_Etype
(Original_Node
(N
), Id
);
4601 -- More than one type derived from Character in given scope.
4602 -- Collect all possible interpretations.
4604 Add_One_Interp
(N
, Id
, Id
);
4612 end Has_Implicit_Character_Literal
;
4614 ----------------------
4615 -- Has_Private_With --
4616 ----------------------
4618 function Has_Private_With
(E
: Entity_Id
) return Boolean is
4619 Comp_Unit
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
4623 Item
:= First
(Context_Items
(Comp_Unit
));
4624 while Present
(Item
) loop
4625 if Nkind
(Item
) = N_With_Clause
4626 and then Private_Present
(Item
)
4627 and then Entity
(Name
(Item
)) = E
4636 end Has_Private_With
;
4638 ---------------------------
4639 -- Has_Implicit_Operator --
4640 ---------------------------
4642 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean is
4643 Op_Id
: constant Name_Id
:= Chars
(Selector_Name
(N
));
4644 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
4646 Priv_Id
: Entity_Id
:= Empty
;
4648 procedure Add_Implicit_Operator
4650 Op_Type
: Entity_Id
:= Empty
);
4651 -- Add implicit interpretation to node N, using the type for which
4652 -- a predefined operator exists. If the operator yields a boolean
4653 -- type, the Operand_Type is implicitly referenced by the operator,
4654 -- and a reference to it must be generated.
4656 ---------------------------
4657 -- Add_Implicit_Operator --
4658 ---------------------------
4660 procedure Add_Implicit_Operator
4662 Op_Type
: Entity_Id
:= Empty
)
4664 Predef_Op
: Entity_Id
;
4667 Predef_Op
:= Current_Entity
(Selector_Name
(N
));
4669 while Present
(Predef_Op
)
4670 and then Scope
(Predef_Op
) /= Standard_Standard
4672 Predef_Op
:= Homonym
(Predef_Op
);
4675 if Nkind
(N
) = N_Selected_Component
then
4676 Change_Selected_Component_To_Expanded_Name
(N
);
4679 Add_One_Interp
(N
, Predef_Op
, T
);
4681 -- For operators with unary and binary interpretations, add both
4683 if Present
(Homonym
(Predef_Op
)) then
4684 Add_One_Interp
(N
, Homonym
(Predef_Op
), T
);
4687 -- The node is a reference to a predefined operator, and
4688 -- an implicit reference to the type of its operands.
4690 if Present
(Op_Type
) then
4691 Generate_Operator_Reference
(N
, Op_Type
);
4693 Generate_Operator_Reference
(N
, T
);
4695 end Add_Implicit_Operator
;
4697 -- Start of processing for Has_Implicit_Operator
4701 if Ekind
(P
) = E_Package
4702 and then not In_Open_Scopes
(P
)
4704 Priv_Id
:= First_Private_Entity
(P
);
4707 Id
:= First_Entity
(P
);
4711 -- Boolean operators: an implicit declaration exists if the scope
4712 -- contains a declaration for a derived Boolean type, or for an
4713 -- array of Boolean type.
4715 when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor
=>
4717 while Id
/= Priv_Id
loop
4719 if Valid_Boolean_Arg
(Id
)
4720 and then Id
= Base_Type
(Id
)
4722 Add_Implicit_Operator
(Id
);
4729 -- Equality: look for any non-limited type (result is Boolean)
4731 when Name_Op_Eq | Name_Op_Ne
=>
4733 while Id
/= Priv_Id
loop
4736 and then not Is_Limited_Type
(Id
)
4737 and then Id
= Base_Type
(Id
)
4739 Add_Implicit_Operator
(Standard_Boolean
, Id
);
4746 -- Comparison operators: scalar type, or array of scalar
4748 when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge
=>
4750 while Id
/= Priv_Id
loop
4751 if (Is_Scalar_Type
(Id
)
4752 or else (Is_Array_Type
(Id
)
4753 and then Is_Scalar_Type
(Component_Type
(Id
))))
4754 and then Id
= Base_Type
(Id
)
4756 Add_Implicit_Operator
(Standard_Boolean
, Id
);
4763 -- Arithmetic operators: any numeric type
4774 while Id
/= Priv_Id
loop
4775 if Is_Numeric_Type
(Id
)
4776 and then Id
= Base_Type
(Id
)
4778 Add_Implicit_Operator
(Id
);
4785 -- Concatenation: any one-dimensional array type
4787 when Name_Op_Concat
=>
4789 while Id
/= Priv_Id
loop
4790 if Is_Array_Type
(Id
) and then Number_Dimensions
(Id
) = 1
4791 and then Id
= Base_Type
(Id
)
4793 Add_Implicit_Operator
(Id
);
4800 -- What is the others condition here? Should we be using a
4801 -- subtype of Name_Id that would restrict to operators ???
4803 when others => null;
4807 -- If we fall through, then we do not have an implicit operator
4811 end Has_Implicit_Operator
;
4813 --------------------
4814 -- In_Open_Scopes --
4815 --------------------
4817 function In_Open_Scopes
(S
: Entity_Id
) return Boolean is
4819 -- Since there are several scope stacks maintained by Scope_Stack each
4820 -- delineated by Standard (see comments by definition of Scope_Stack)
4821 -- it is necessary to end the search when Standard is reached.
4823 for J
in reverse 0 .. Scope_Stack
.Last
loop
4824 if Scope_Stack
.Table
(J
).Entity
= S
then
4828 -- We need Is_Active_Stack_Base to tell us when to stop rather
4829 -- than checking for Standard_Standard because there are cases
4830 -- where Standard_Standard appears in the middle of the active
4831 -- set of scopes. This affects the declaration and overriding
4832 -- of private inherited operations in instantiations of generic
4835 exit when Scope_Stack
.Table
(J
).Is_Active_Stack_Base
;
4841 -----------------------------
4842 -- Inherit_Renamed_Profile --
4843 -----------------------------
4845 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
) is
4852 if Ekind
(Old_S
) = E_Operator
then
4854 New_F
:= First_Formal
(New_S
);
4856 while Present
(New_F
) loop
4857 Set_Etype
(New_F
, Base_Type
(Etype
(New_F
)));
4858 Next_Formal
(New_F
);
4861 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
4864 New_F
:= First_Formal
(New_S
);
4865 Old_F
:= First_Formal
(Old_S
);
4867 while Present
(New_F
) loop
4868 New_T
:= Etype
(New_F
);
4869 Old_T
:= Etype
(Old_F
);
4871 -- If the new type is a renaming of the old one, as is the
4872 -- case for actuals in instances, retain its name, to simplify
4873 -- later disambiguation.
4875 if Nkind
(Parent
(New_T
)) = N_Subtype_Declaration
4876 and then Is_Entity_Name
(Subtype_Indication
(Parent
(New_T
)))
4877 and then Entity
(Subtype_Indication
(Parent
(New_T
))) = Old_T
4881 Set_Etype
(New_F
, Old_T
);
4884 Next_Formal
(New_F
);
4885 Next_Formal
(Old_F
);
4888 if Ekind
(Old_S
) = E_Function
4889 or else Ekind
(Old_S
) = E_Enumeration_Literal
4891 Set_Etype
(New_S
, Etype
(Old_S
));
4894 end Inherit_Renamed_Profile
;
4900 procedure Initialize
is
4905 -------------------------
4906 -- Install_Use_Clauses --
4907 -------------------------
4909 procedure Install_Use_Clauses
4911 Force_Installation
: Boolean := False)
4913 U
: Node_Id
:= Clause
;
4918 while Present
(U
) loop
4920 -- Case of USE package
4922 if Nkind
(U
) = N_Use_Package_Clause
then
4923 P
:= First
(Names
(U
));
4925 while Present
(P
) loop
4928 if Ekind
(Id
) = E_Package
then
4931 Set_Redundant_Use
(P
, True);
4933 elsif Present
(Renamed_Object
(Id
))
4934 and then In_Use
(Renamed_Object
(Id
))
4936 Set_Redundant_Use
(P
, True);
4938 elsif Force_Installation
or else Applicable_Use
(P
) then
4939 Use_One_Package
(Id
, U
);
4950 P
:= First
(Subtype_Marks
(U
));
4952 while Present
(P
) loop
4953 if not Is_Entity_Name
(P
)
4954 or else No
(Entity
(P
))
4958 elsif Entity
(P
) /= Any_Type
then
4966 Next_Use_Clause
(U
);
4968 end Install_Use_Clauses
;
4970 -------------------------------------
4971 -- Is_Appropriate_For_Entry_Prefix --
4972 -------------------------------------
4974 function Is_Appropriate_For_Entry_Prefix
(T
: Entity_Id
) return Boolean is
4975 P_Type
: Entity_Id
:= T
;
4978 if Is_Access_Type
(P_Type
) then
4979 P_Type
:= Designated_Type
(P_Type
);
4982 return Is_Task_Type
(P_Type
) or else Is_Protected_Type
(P_Type
);
4983 end Is_Appropriate_For_Entry_Prefix
;
4985 -------------------------------
4986 -- Is_Appropriate_For_Record --
4987 -------------------------------
4989 function Is_Appropriate_For_Record
(T
: Entity_Id
) return Boolean is
4991 function Has_Components
(T1
: Entity_Id
) return Boolean;
4992 -- Determine if given type has components (i.e. is either a record
4993 -- type or a type that has discriminants).
4995 function Has_Components
(T1
: Entity_Id
) return Boolean is
4997 return Is_Record_Type
(T1
)
4998 or else (Is_Private_Type
(T1
) and then Has_Discriminants
(T1
))
4999 or else (Is_Task_Type
(T1
) and then Has_Discriminants
(T1
));
5002 -- Start of processing for Is_Appropriate_For_Record
5007 and then (Has_Components
(T
)
5008 or else (Is_Access_Type
(T
)
5010 Has_Components
(Designated_Type
(T
))));
5011 end Is_Appropriate_For_Record
;
5017 procedure New_Scope
(S
: Entity_Id
) is
5021 if Ekind
(S
) = E_Void
then
5024 -- Set scope depth if not a non-concurrent type, and we have not
5025 -- yet set the scope depth. This means that we have the first
5026 -- occurrence of the scope, and this is where the depth is set.
5028 elsif (not Is_Type
(S
) or else Is_Concurrent_Type
(S
))
5029 and then not Scope_Depth_Set
(S
)
5031 if S
= Standard_Standard
then
5032 Set_Scope_Depth_Value
(S
, Uint_0
);
5034 elsif Is_Child_Unit
(S
) then
5035 Set_Scope_Depth_Value
(S
, Uint_1
);
5037 elsif not Is_Record_Type
(Current_Scope
) then
5038 if Ekind
(S
) = E_Loop
then
5039 Set_Scope_Depth_Value
(S
, Scope_Depth
(Current_Scope
));
5041 Set_Scope_Depth_Value
(S
, Scope_Depth
(Current_Scope
) + 1);
5046 Scope_Stack
.Increment_Last
;
5049 SST
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
5053 SST
.Save_Scope_Suppress
:= Scope_Suppress
;
5054 SST
.Save_Local_Entity_Suppress
:= Local_Entity_Suppress
.Last
;
5056 if Scope_Stack
.Last
> Scope_Stack
.First
then
5057 SST
.Component_Alignment_Default
:= Scope_Stack
.Table
5058 (Scope_Stack
.Last
- 1).
5059 Component_Alignment_Default
;
5062 SST
.Last_Subprogram_Name
:= null;
5063 SST
.Is_Transient
:= False;
5064 SST
.Node_To_Be_Wrapped
:= Empty
;
5065 SST
.Pending_Freeze_Actions
:= No_List
;
5066 SST
.Actions_To_Be_Wrapped_Before
:= No_List
;
5067 SST
.Actions_To_Be_Wrapped_After
:= No_List
;
5068 SST
.First_Use_Clause
:= Empty
;
5069 SST
.Is_Active_Stack_Base
:= False;
5072 if Debug_Flag_W
then
5073 Write_Str
("--> new scope: ");
5074 Write_Name
(Chars
(Current_Scope
));
5075 Write_Str
(", Id=");
5076 Write_Int
(Int
(Current_Scope
));
5077 Write_Str
(", Depth=");
5078 Write_Int
(Int
(Scope_Stack
.Last
));
5082 -- Copy from Scope (S) the categorization flags to S, this is not
5083 -- done in case Scope (S) is Standard_Standard since propagation
5084 -- is from library unit entity inwards.
5086 if S
/= Standard_Standard
5087 and then Scope
(S
) /= Standard_Standard
5088 and then not Is_Child_Unit
(S
)
5092 if Nkind
(E
) not in N_Entity
then
5096 -- We only propagate inwards for library level entities,
5097 -- inner level subprograms do not inherit the categorization.
5099 if Is_Library_Level_Entity
(S
) then
5100 Set_Is_Preelaborated
(S
, Is_Preelaborated
(E
));
5101 Set_Is_Shared_Passive
(S
, Is_Shared_Passive
(E
));
5102 Set_Categorization_From_Scope
(E
=> S
, Scop
=> E
);
5111 procedure Pop_Scope
is
5112 SST
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
5115 if Debug_Flag_E
then
5119 Scope_Suppress
:= SST
.Save_Scope_Suppress
;
5120 Local_Entity_Suppress
.Set_Last
(SST
.Save_Local_Entity_Suppress
);
5122 if Debug_Flag_W
then
5123 Write_Str
("--> exiting scope: ");
5124 Write_Name
(Chars
(Current_Scope
));
5125 Write_Str
(", Depth=");
5126 Write_Int
(Int
(Scope_Stack
.Last
));
5130 End_Use_Clauses
(SST
.First_Use_Clause
);
5132 -- If the actions to be wrapped are still there they will get lost
5133 -- causing incomplete code to be generated. It is better to abort in
5134 -- this case (and we do the abort even with assertions off since the
5135 -- penalty is incorrect code generation)
5137 if SST
.Actions_To_Be_Wrapped_Before
/= No_List
5139 SST
.Actions_To_Be_Wrapped_After
/= No_List
5144 -- Free last subprogram name if allocated, and pop scope
5146 Free
(SST
.Last_Subprogram_Name
);
5147 Scope_Stack
.Decrement_Last
;
5150 ---------------------
5151 -- Premature_Usage --
5152 ---------------------
5154 procedure Premature_Usage
(N
: Node_Id
) is
5155 Kind
: constant Node_Kind
:= Nkind
(Parent
(Entity
(N
)));
5156 E
: Entity_Id
:= Entity
(N
);
5159 -- Within an instance, the analysis of the actual for a formal object
5160 -- does not see the name of the object itself. This is significant
5161 -- only if the object is an aggregate, where its analysis does not do
5162 -- any name resolution on component associations. (see 4717-008). In
5163 -- such a case, look for the visible homonym on the chain.
5166 and then Present
(Homonym
(E
))
5171 and then not In_Open_Scopes
(Scope
(E
))
5178 Set_Etype
(N
, Etype
(E
));
5183 if Kind
= N_Component_Declaration
then
5185 ("component&! cannot be used before end of record declaration", N
);
5187 elsif Kind
= N_Parameter_Specification
then
5189 ("formal parameter&! cannot be used before end of specification",
5192 elsif Kind
= N_Discriminant_Specification
then
5194 ("discriminant&! cannot be used before end of discriminant part",
5197 elsif Kind
= N_Procedure_Specification
5198 or else Kind
= N_Function_Specification
5201 ("subprogram&! cannot be used before end of its declaration",
5205 ("object& cannot be used before end of its declaration!", N
);
5207 end Premature_Usage
;
5209 ------------------------
5210 -- Present_System_Aux --
5211 ------------------------
5213 function Present_System_Aux
(N
: Node_Id
:= Empty
) return Boolean is
5216 Unum
: Unit_Number_Type
;
5221 function Find_System
(C_Unit
: Node_Id
) return Entity_Id
;
5222 -- Scan context clause of compilation unit to find a with_clause
5229 function Find_System
(C_Unit
: Node_Id
) return Entity_Id
is
5230 With_Clause
: Node_Id
;
5233 With_Clause
:= First
(Context_Items
(C_Unit
));
5235 while Present
(With_Clause
) loop
5236 if (Nkind
(With_Clause
) = N_With_Clause
5237 and then Chars
(Name
(With_Clause
)) = Name_System
)
5238 and then Comes_From_Source
(With_Clause
)
5249 -- Start of processing for Present_System_Aux
5252 -- The child unit may have been loaded and analyzed already
5254 if Present
(System_Aux_Id
) then
5257 -- If no previous pragma for System.Aux, nothing to load
5259 elsif No
(System_Extend_Unit
) then
5262 -- Use the unit name given in the pragma to retrieve the unit.
5263 -- Verify that System itself appears in the context clause of the
5264 -- current compilation. If System is not present, an error will
5265 -- have been reported already.
5268 With_Sys
:= Find_System
(Cunit
(Current_Sem_Unit
));
5270 The_Unit
:= Unit
(Cunit
(Current_Sem_Unit
));
5273 and then (Nkind
(The_Unit
) = N_Package_Body
5274 or else (Nkind
(The_Unit
) = N_Subprogram_Body
5275 and then not Acts_As_Spec
(Cunit
(Current_Sem_Unit
))))
5277 With_Sys
:= Find_System
(Library_Unit
(Cunit
(Current_Sem_Unit
)));
5281 and then Present
(N
)
5283 -- If we are compiling a subunit, we need to examine its
5284 -- context as well (Current_Sem_Unit is the parent unit);
5286 The_Unit
:= Parent
(N
);
5288 while Nkind
(The_Unit
) /= N_Compilation_Unit
loop
5289 The_Unit
:= Parent
(The_Unit
);
5292 if Nkind
(Unit
(The_Unit
)) = N_Subunit
then
5293 With_Sys
:= Find_System
(The_Unit
);
5297 if No
(With_Sys
) then
5301 Loc
:= Sloc
(With_Sys
);
5302 Get_Name_String
(Chars
(Expression
(System_Extend_Unit
)));
5303 Name_Buffer
(8 .. Name_Len
+ 7) := Name_Buffer
(1 .. Name_Len
);
5304 Name_Buffer
(1 .. 7) := "system.";
5305 Name_Buffer
(Name_Len
+ 8) := '%';
5306 Name_Buffer
(Name_Len
+ 9) := 's';
5307 Name_Len
:= Name_Len
+ 9;
5308 Aux_Name
:= Name_Find
;
5312 (Load_Name
=> Aux_Name
,
5315 Error_Node
=> With_Sys
);
5317 if Unum
/= No_Unit
then
5318 Semantics
(Cunit
(Unum
));
5320 Defining_Entity
(Specification
(Unit
(Cunit
(Unum
))));
5322 Withn
:= Make_With_Clause
(Loc
,
5324 Make_Expanded_Name
(Loc
,
5325 Chars
=> Chars
(System_Aux_Id
),
5327 New_Reference_To
(Scope
(System_Aux_Id
), Loc
),
5329 New_Reference_To
(System_Aux_Id
, Loc
)));
5331 Set_Entity
(Name
(Withn
), System_Aux_Id
);
5333 Set_Library_Unit
(Withn
, Cunit
(Unum
));
5334 Set_Corresponding_Spec
(Withn
, System_Aux_Id
);
5335 Set_First_Name
(Withn
, True);
5336 Set_Implicit_With
(Withn
, True);
5338 Insert_After
(With_Sys
, Withn
);
5339 Mark_Rewrite_Insertion
(Withn
);
5340 Set_Context_Installed
(Withn
);
5344 -- Here if unit load failed
5347 Error_Msg_Name_1
:= Name_System
;
5348 Error_Msg_Name_2
:= Chars
(Expression
(System_Extend_Unit
));
5350 ("extension package `%.%` does not exist",
5351 Opt
.System_Extend_Unit
);
5355 end Present_System_Aux
;
5357 -------------------------
5358 -- Restore_Scope_Stack --
5359 -------------------------
5361 procedure Restore_Scope_Stack
(Handle_Use
: Boolean := True) is
5364 Comp_Unit
: Node_Id
;
5365 In_Child
: Boolean := False;
5366 Full_Vis
: Boolean := True;
5367 SS_Last
: constant Int
:= Scope_Stack
.Last
;
5370 -- Restore visibility of previous scope stack, if any
5372 for J
in reverse 0 .. Scope_Stack
.Last
loop
5373 exit when Scope_Stack
.Table
(J
).Entity
= Standard_Standard
5374 or else No
(Scope_Stack
.Table
(J
).Entity
);
5376 S
:= Scope_Stack
.Table
(J
).Entity
;
5378 if not Is_Hidden_Open_Scope
(S
) then
5380 -- If the parent scope is hidden, its entities are hidden as
5381 -- well, unless the entity is the instantiation currently
5384 if not Is_Hidden_Open_Scope
(Scope
(S
))
5385 or else not Analyzed
(Parent
(S
))
5386 or else Scope
(S
) = Standard_Standard
5388 Set_Is_Immediately_Visible
(S
, True);
5391 E
:= First_Entity
(S
);
5393 while Present
(E
) loop
5394 if Is_Child_Unit
(E
) then
5395 Set_Is_Immediately_Visible
(E
,
5396 Is_Visible_Child_Unit
(E
) or else In_Open_Scopes
(E
));
5398 Set_Is_Immediately_Visible
(E
, True);
5403 if not Full_Vis
then
5404 exit when E
= First_Private_Entity
(S
);
5408 -- The visibility of child units (siblings of current compilation)
5409 -- must be restored in any case. Their declarations may appear
5410 -- after the private part of the parent.
5413 and then Present
(E
)
5415 while Present
(E
) loop
5416 if Is_Child_Unit
(E
) then
5417 Set_Is_Immediately_Visible
(E
,
5418 Is_Visible_Child_Unit
(E
) or else In_Open_Scopes
(E
));
5426 if Is_Child_Unit
(S
)
5427 and not In_Child
-- check only for current unit.
5431 -- restore visibility of parents according to whether the child
5432 -- is private and whether we are in its visible part.
5434 Comp_Unit
:= Parent
(Unit_Declaration_Node
(S
));
5436 if Nkind
(Comp_Unit
) = N_Compilation_Unit
5437 and then Private_Present
(Comp_Unit
)
5441 elsif (Ekind
(S
) = E_Package
5442 or else Ekind
(S
) = E_Generic_Package
)
5443 and then (In_Private_Part
(S
)
5444 or else In_Package_Body
(S
))
5448 elsif (Ekind
(S
) = E_Procedure
5449 or else Ekind
(S
) = E_Function
)
5450 and then Has_Completion
(S
)
5461 if SS_Last
>= Scope_Stack
.First
5462 and then Scope_Stack
.Table
(SS_Last
).Entity
/= Standard_Standard
5465 Install_Use_Clauses
(Scope_Stack
.Table
(SS_Last
).First_Use_Clause
);
5467 end Restore_Scope_Stack
;
5469 ----------------------
5470 -- Save_Scope_Stack --
5471 ----------------------
5473 procedure Save_Scope_Stack
(Handle_Use
: Boolean := True) is
5476 SS_Last
: constant Int
:= Scope_Stack
.Last
;
5479 if SS_Last
>= Scope_Stack
.First
5480 and then Scope_Stack
.Table
(SS_Last
).Entity
/= Standard_Standard
5483 End_Use_Clauses
(Scope_Stack
.Table
(SS_Last
).First_Use_Clause
);
5486 -- If the call is from within a compilation unit, as when
5487 -- called from Rtsfind, make current entries in scope stack
5488 -- invisible while we analyze the new unit.
5490 for J
in reverse 0 .. SS_Last
loop
5491 exit when Scope_Stack
.Table
(J
).Entity
= Standard_Standard
5492 or else No
(Scope_Stack
.Table
(J
).Entity
);
5494 S
:= Scope_Stack
.Table
(J
).Entity
;
5495 Set_Is_Immediately_Visible
(S
, False);
5496 E
:= First_Entity
(S
);
5498 while Present
(E
) loop
5499 Set_Is_Immediately_Visible
(E
, False);
5505 end Save_Scope_Stack
;
5511 procedure Set_Use
(L
: List_Id
) is
5513 Pack_Name
: Node_Id
;
5521 while Present
(Decl
) loop
5522 if Nkind
(Decl
) = N_Use_Package_Clause
then
5523 Chain_Use_Clause
(Decl
);
5524 Pack_Name
:= First
(Names
(Decl
));
5526 while Present
(Pack_Name
) loop
5527 Pack
:= Entity
(Pack_Name
);
5529 if Ekind
(Pack
) = E_Package
5530 and then Applicable_Use
(Pack_Name
)
5532 Use_One_Package
(Pack
, Decl
);
5538 elsif Nkind
(Decl
) = N_Use_Type_Clause
then
5539 Chain_Use_Clause
(Decl
);
5540 Id
:= First
(Subtype_Marks
(Decl
));
5542 while Present
(Id
) loop
5543 if Entity
(Id
) /= Any_Type
then
5556 ---------------------
5557 -- Use_One_Package --
5558 ---------------------
5560 procedure Use_One_Package
(P
: Entity_Id
; N
: Node_Id
) is
5563 Current_Instance
: Entity_Id
:= Empty
;
5565 Private_With_OK
: Boolean := False;
5568 if Ekind
(P
) /= E_Package
then
5574 -- Ada 2005 (AI-50217): Check restriction
5576 if From_With_Type
(P
) then
5577 Error_Msg_N
("limited withed package cannot appear in use clause", N
);
5580 -- Find enclosing instance, if any
5583 Current_Instance
:= Current_Scope
;
5585 while not Is_Generic_Instance
(Current_Instance
) loop
5586 Current_Instance
:= Scope
(Current_Instance
);
5589 if No
(Hidden_By_Use_Clause
(N
)) then
5590 Set_Hidden_By_Use_Clause
(N
, New_Elmt_List
);
5594 -- If unit is a package renaming, indicate that the renamed
5595 -- package is also in use (the flags on both entities must
5596 -- remain consistent, and a subsequent use of either of them
5597 -- should be recognized as redundant).
5599 if Present
(Renamed_Object
(P
)) then
5600 Set_In_Use
(Renamed_Object
(P
));
5601 Real_P
:= Renamed_Object
(P
);
5606 -- Ada 2005 (AI-262): Check the use_clause of a private withed package
5607 -- found in the private part of a package specification
5609 if In_Private_Part
(Current_Scope
)
5610 and then Has_Private_With
(P
)
5611 and then Is_Child_Unit
(Current_Scope
)
5612 and then Is_Child_Unit
(P
)
5613 and then Is_Ancestor_Package
(Scope
(Current_Scope
), P
)
5615 Private_With_OK
:= True;
5618 -- Loop through entities in one package making them potentially
5621 Id
:= First_Entity
(P
);
5623 and then (Id
/= First_Private_Entity
(P
)
5624 or else Private_With_OK
) -- Ada 2005 (AI-262)
5626 Prev
:= Current_Entity
(Id
);
5628 while Present
(Prev
) loop
5629 if Is_Immediately_Visible
(Prev
)
5630 and then (not Is_Overloadable
(Prev
)
5631 or else not Is_Overloadable
(Id
)
5632 or else (Type_Conformant
(Id
, Prev
)))
5634 if No
(Current_Instance
) then
5636 -- Potentially use-visible entity remains hidden
5638 goto Next_Usable_Entity
;
5640 -- A use clause within an instance hides outer global
5641 -- entities, which are not used to resolve local entities
5642 -- in the instance. Note that the predefined entities in
5643 -- Standard could not have been hidden in the generic by
5644 -- a use clause, and therefore remain visible. Other
5645 -- compilation units whose entities appear in Standard must
5646 -- be hidden in an instance.
5648 -- To determine whether an entity is external to the instance
5649 -- we compare the scope depth of its scope with that of the
5650 -- current instance. However, a generic actual of a subprogram
5651 -- instance is declared in the wrapper package but will not be
5652 -- hidden by a use-visible entity.
5654 -- If Id is called Standard, the predefined package with the
5655 -- same name is in the homonym chain. It has to be ignored
5656 -- because it has no defined scope (being the only entity in
5657 -- the system with this mandated behavior).
5659 elsif not Is_Hidden
(Id
)
5660 and then Present
(Scope
(Prev
))
5661 and then not Is_Wrapper_Package
(Scope
(Prev
))
5662 and then Scope_Depth
(Scope
(Prev
)) <
5663 Scope_Depth
(Current_Instance
)
5664 and then (Scope
(Prev
) /= Standard_Standard
5665 or else Sloc
(Prev
) > Standard_Location
)
5667 Set_Is_Potentially_Use_Visible
(Id
);
5668 Set_Is_Immediately_Visible
(Prev
, False);
5669 Append_Elmt
(Prev
, Hidden_By_Use_Clause
(N
));
5672 -- A user-defined operator is not use-visible if the
5673 -- predefined operator for the type is immediately visible,
5674 -- which is the case if the type of the operand is in an open
5675 -- scope. This does not apply to user-defined operators that
5676 -- have operands of different types, because the predefined
5677 -- mixed mode operations (multiplication and division) apply to
5678 -- universal types and do not hide anything.
5680 elsif Ekind
(Prev
) = E_Operator
5681 and then Operator_Matches_Spec
(Prev
, Id
)
5682 and then In_Open_Scopes
5683 (Scope
(Base_Type
(Etype
(First_Formal
(Id
)))))
5684 and then (No
(Next_Formal
(First_Formal
(Id
)))
5685 or else Etype
(First_Formal
(Id
))
5686 = Etype
(Next_Formal
(First_Formal
(Id
)))
5687 or else Chars
(Prev
) = Name_Op_Expon
)
5689 goto Next_Usable_Entity
;
5692 Prev
:= Homonym
(Prev
);
5695 -- On exit, we know entity is not hidden, unless it is private
5697 if not Is_Hidden
(Id
)
5698 and then ((not Is_Child_Unit
(Id
))
5699 or else Is_Visible_Child_Unit
(Id
))
5701 Set_Is_Potentially_Use_Visible
(Id
);
5703 if Is_Private_Type
(Id
)
5704 and then Present
(Full_View
(Id
))
5706 Set_Is_Potentially_Use_Visible
(Full_View
(Id
));
5710 <<Next_Usable_Entity
>>
5714 -- Child units are also made use-visible by a use clause, but they
5715 -- may appear after all visible declarations in the parent entity list.
5717 while Present
(Id
) loop
5719 if Is_Child_Unit
(Id
)
5720 and then Is_Visible_Child_Unit
(Id
)
5722 Set_Is_Potentially_Use_Visible
(Id
);
5728 if Chars
(Real_P
) = Name_System
5729 and then Scope
(Real_P
) = Standard_Standard
5730 and then Present_System_Aux
(N
)
5732 Use_One_Package
(System_Aux_Id
, N
);
5735 end Use_One_Package
;
5741 procedure Use_One_Type
(Id
: Node_Id
) is
5747 -- It is the type determined by the subtype mark (8.4(8)) whose
5748 -- operations become potentially use-visible.
5750 T
:= Base_Type
(Entity
(Id
));
5755 or else Is_Potentially_Use_Visible
(T
)
5756 or else In_Use
(Scope
(T
)));
5758 if In_Open_Scopes
(Scope
(T
)) then
5761 -- If the subtype mark designates a subtype in a different package,
5762 -- we have to check that the parent type is visible, otherwise the
5763 -- use type clause is a noop. Not clear how to do that???
5765 elsif not Redundant_Use
(Id
) then
5767 Op_List
:= Collect_Primitive_Operations
(T
);
5768 Elmt
:= First_Elmt
(Op_List
);
5770 while Present
(Elmt
) loop
5772 if (Nkind
(Node
(Elmt
)) = N_Defining_Operator_Symbol
5773 or else Chars
(Node
(Elmt
)) in Any_Operator_Name
)
5774 and then not Is_Hidden
(Node
(Elmt
))
5776 Set_Is_Potentially_Use_Visible
(Node
(Elmt
));
5788 procedure Write_Info
is
5789 Id
: Entity_Id
:= First_Entity
(Current_Scope
);
5792 -- No point in dumping standard entities
5794 if Current_Scope
= Standard_Standard
then
5798 Write_Str
("========================================================");
5800 Write_Str
(" Defined Entities in ");
5801 Write_Name
(Chars
(Current_Scope
));
5803 Write_Str
("========================================================");
5807 Write_Str
("-- none --");
5811 while Present
(Id
) loop
5812 Write_Entity_Info
(Id
, " ");
5817 if Scope
(Current_Scope
) = Standard_Standard
then
5819 -- Print information on the current unit itself
5821 Write_Entity_Info
(Current_Scope
, " ");
5831 procedure Write_Scopes
is
5835 for J
in reverse 1 .. Scope_Stack
.Last
loop
5836 S
:= Scope_Stack
.Table
(J
).Entity
;
5837 Write_Int
(Int
(S
));
5838 Write_Str
(" === ");
5839 Write_Name
(Chars
(S
));