1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2001, 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 Rtsfind
; use Rtsfind
;
46 with Sem_Ch3
; use Sem_Ch3
;
47 with Sem_Ch4
; use Sem_Ch4
;
48 with Sem_Ch6
; use Sem_Ch6
;
49 with Sem_Ch12
; use Sem_Ch12
;
50 with Sem_Res
; use Sem_Res
;
51 with Sem_Util
; use Sem_Util
;
52 with Sem_Type
; use Sem_Type
;
53 with Stand
; use Stand
;
54 with Sinfo
; use Sinfo
;
55 with Sinfo
.CN
; use Sinfo
.CN
;
56 with Snames
; use Snames
;
57 with Style
; use Style
;
59 with Tbuild
; use Tbuild
;
60 with Uintp
; use Uintp
;
62 with GNAT
.Spelling_Checker
; use GNAT
.Spelling_Checker
;
64 package body Sem_Ch8
is
66 ------------------------------------
67 -- Visibility and Name Resolution --
68 ------------------------------------
70 -- This package handles name resolution and the collection of
71 -- interpretations for overloaded names, prior to overload resolution.
73 -- Name resolution is the process that establishes a mapping between source
74 -- identifiers and the entities they denote at each point in the program.
75 -- Each entity is represented by a defining occurrence. Each identifier
76 -- that denotes an entity points to the corresponding defining occurrence.
77 -- This is the entity of the applied occurrence. Each occurrence holds
78 -- an index into the names table, where source identifiers are stored.
80 -- Each entry in the names table for an identifier or designator uses the
81 -- Info pointer to hold a link to the currently visible entity that has
82 -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id
83 -- in package Sem_Util). The visibility is initialized at the beginning of
84 -- semantic processing to make entities in package Standard immediately
85 -- visible. The visibility table is used in a more subtle way when
86 -- compiling subunits (see below).
88 -- Entities that have the same name (i.e. homonyms) are chained. In the
89 -- case of overloaded entities, this chain holds all the possible meanings
90 -- of a given identifier. The process of overload resolution uses type
91 -- information to select from this chain the unique meaning of a given
94 -- Entities are also chained in their scope, through the Next_Entity link.
95 -- As a consequence, the name space is organized as a sparse matrix, where
96 -- each row corresponds to a scope, and each column to a source identifier.
97 -- Open scopes, that is to say scopes currently being compiled, have their
98 -- corresponding rows of entities in order, innermost scope first.
100 -- The scopes of packages that are mentioned in context clauses appear in
101 -- no particular order, interspersed among open scopes. This is because
102 -- in the course of analyzing the context of a compilation, a package
103 -- declaration is first an open scope, and subsequently an element of the
104 -- context. If subunits or child units are present, a parent unit may
105 -- appear under various guises at various times in the compilation.
107 -- When the compilation of the innermost scope is complete, the entities
108 -- defined therein are no longer visible. If the scope is not a package
109 -- declaration, these entities are never visible subsequently, and can be
110 -- removed from visibility chains. If the scope is a package declaration,
111 -- its visible declarations may still be accessible. Therefore the entities
112 -- defined in such a scope are left on the visibility chains, and only
113 -- their visibility (immediately visibility or potential use-visibility)
116 -- The ordering of homonyms on their chain does not necessarily follow
117 -- the order of their corresponding scopes on the scope stack. For
118 -- example, if package P and the enclosing scope both contain entities
119 -- named E, then when compiling the package body the chain for E will
120 -- hold the global entity first, and the local one (corresponding to
121 -- the current inner scope) next. As a result, name resolution routines
122 -- do not assume any relative ordering of the homonym chains, either
123 -- for scope nesting or to order of appearance of context clauses.
125 -- When compiling a child unit, entities in the parent scope are always
126 -- immediately visible. When compiling the body of a child unit, private
127 -- entities in the parent must also be made immediately visible. There
128 -- are separate routines to make the visible and private declarations
129 -- visible at various times (see package Sem_Ch7).
131 -- +--------+ +-----+
132 -- | In use |-------->| EU1 |-------------------------->
133 -- +--------+ +-----+
135 -- +--------+ +-----+ +-----+
136 -- | Stand. |---------------->| ES1 |--------------->| ES2 |--->
137 -- +--------+ +-----+ +-----+
139 -- +---------+ | +-----+
140 -- | with'ed |------------------------------>| EW2 |--->
141 -- +---------+ | +-----+
143 -- +--------+ +-----+ +-----+
144 -- | Scope2 |---------------->| E12 |--------------->| E22 |--->
145 -- +--------+ +-----+ +-----+
147 -- +--------+ +-----+ +-----+
148 -- | Scope1 |---------------->| E11 |--------------->| E12 |--->
149 -- +--------+ +-----+ +-----+
153 -- | | with'ed |----------------------------------------->
157 -- (innermost first) | |
158 -- +----------------------------+
159 -- Names table => | Id1 | | | | Id2 |
160 -- +----------------------------+
162 -- Name resolution must deal with several syntactic forms: simple names,
163 -- qualified names, indexed names, and various forms of calls.
165 -- Each identifier points to an entry in the names table. The resolution
166 -- of a simple name consists in traversing the homonym chain, starting
167 -- from the names table. If an entry is immediately visible, it is the one
168 -- designated by the identifier. If only potemtially use-visible entities
169 -- are on the chain, we must verify that they do not hide each other. If
170 -- the entity we find is overloadable, we collect all other overloadable
171 -- entities on the chain as long as they are not hidden.
173 -- To resolve expanded names, we must find the entity at the intersection
174 -- of the entity chain for the scope (the prefix) and the homonym chain
175 -- for the selector. In general, homonym chains will be much shorter than
176 -- entity chains, so it is preferable to start from the names table as
177 -- well. If the entity found is overloadable, we must collect all other
178 -- interpretations that are defined in the scope denoted by the prefix.
180 -- For records, protected types, and tasks, their local entities are
181 -- removed from visibility chains on exit from the corresponding scope.
182 -- From the outside, these entities are always accessed by selected
183 -- notation, and the entity chain for the record type, protected type,
184 -- etc. is traversed sequentially in order to find the designated entity.
186 -- The discriminants of a type and the operations of a protected type or
187 -- task are unchained on exit from the first view of the type, (such as
188 -- a private or incomplete type declaration, or a protected type speci-
189 -- fication) and rechained when compiling the second view.
191 -- In the case of operators, we do not make operators on derived types
192 -- explicit. As a result, the notation P."+" may denote either a user-
193 -- defined function with name "+", or else an implicit declaration of the
194 -- operator "+" in package P. The resolution of expanded names always
195 -- tries to resolve an operator name as such an implicitly defined entity,
196 -- in addition to looking for explicit declarations.
198 -- All forms of names that denote entities (simple names, expanded names,
199 -- character literals in some cases) have a Entity attribute, which
200 -- identifies the entity denoted by the name.
202 ---------------------
203 -- The Scope Stack --
204 ---------------------
206 -- The Scope stack keeps track of the scopes currently been compiled.
207 -- Every entity that contains declarations (including records) is placed
208 -- on the scope stack while it is being processed, and removed at the end.
209 -- Whenever a non-package scope is exited, the entities defined therein
210 -- are removed from the visibility table, so that entities in outer scopes
211 -- become visible (see previous description). On entry to Sem, the scope
212 -- stack only contains the package Standard. As usual, subunits complicate
213 -- this picture ever so slightly.
215 -- The Rtsfind mechanism can force a call to Semantics while another
216 -- compilation is in progress. The unit retrieved by Rtsfind must be
217 -- compiled in its own context, and has no access to the visibility of
218 -- the unit currently being compiled. The procedures Save_Scope_Stack and
219 -- Restore_Scope_Stack make entities in current open scopes invisible
220 -- before compiling the retrieved unit, and restore the compilation
221 -- environment afterwards.
223 ------------------------
224 -- Compiling subunits --
225 ------------------------
227 -- Subunits must be compiled in the environment of the corresponding
228 -- stub, that is to say with the same visibility into the parent (and its
229 -- context) that is available at the point of the stub declaration, but
230 -- with the additional visibility provided by the context clause of the
231 -- subunit itself. As a result, compilation of a subunit forces compilation
232 -- of the parent (see description in lib-). At the point of the stub
233 -- declaration, Analyze is called recursively to compile the proper body
234 -- of the subunit, but without reinitializing the names table, nor the
235 -- scope stack (i.e. standard is not pushed on the stack). In this fashion
236 -- the context of the subunit is added to the context of the parent, and
237 -- the subunit is compiled in the correct environment. Note that in the
238 -- course of processing the context of a subunit, Standard will appear
239 -- twice on the scope stack: once for the parent of the subunit, and
240 -- once for the unit in the context clause being compiled. However, the
241 -- two sets of entities are not linked by homonym chains, so that the
242 -- compilation of any context unit happens in a fresh visibility
245 -------------------------------
246 -- Processing of USE Clauses --
247 -------------------------------
249 -- Every defining occurrence has a flag indicating if it is potentially use
250 -- visible. Resolution of simple names examines this flag. The processing
251 -- of use clauses consists in setting this flag on all visible entities
252 -- defined in the corresponding package. On exit from the scope of the use
253 -- clause, the corresponding flag must be reset. However, a package may
254 -- appear in several nested use clauses (pathological but legal, alas!)
255 -- which forces us to use a slightly more involved scheme:
257 -- a) The defining occurrence for a package holds a flag -In_Use- to
258 -- indicate that it is currently in the scope of a use clause. If a
259 -- redundant use clause is encountered, then the corresponding occurrence
260 -- of the package name is flagged -Redundant_Use-.
262 -- b) On exit from a scope, the use clauses in its declarative part are
263 -- scanned. The visibility flag is reset in all entities declared in
264 -- package named in a use clause, as long as the package is not flagged
265 -- as being in a redundant use clause (in which case the outer use
266 -- clause is still in effect, and the direct visibility of its entities
267 -- must be retained).
269 -- Note that entities are not removed from their homonym chains on exit
270 -- from the package specification. A subsequent use clause does not need
271 -- to rechain the visible entities, but only to establish their direct
274 -----------------------------------
275 -- Handling private declarations --
276 -----------------------------------
278 -- The principle that each entity has a single defining occurrence clashes
279 -- with the presence of two separate definitions for private types: the
280 -- first is the private type declaration, and second is the full type
281 -- declaration. It is important that all references to the type point to
282 -- the same defining occurrence, namely the first one. To enforce the two
283 -- separate views of the entity, the corresponding information is swapped
284 -- between the two declarations. Outside of the package, the defining
285 -- occurrence only contains the private declaration information, while in
286 -- the private part and the body of the package the defining occurrence
287 -- contains the full declaration. To simplify the swap, the defining
288 -- occurrence that currently holds the private declaration points to the
289 -- full declaration. During semantic processing the defining occurrence
290 -- also points to a list of private dependents, that is to say access
291 -- types or composite types whose designated types or component types are
292 -- subtypes or derived types of the private type in question. After the
293 -- full declaration has been seen, the private dependents are updated to
294 -- indicate that they have full definitions.
296 ------------------------------------
297 -- Handling of Undefined Messages --
298 ------------------------------------
300 -- In normal mode, only the first use of an undefined identifier generates
301 -- a message. The table Urefs is used to record error messages that have
302 -- been issued so that second and subsequent ones do not generate further
303 -- messages. However, the second reference causes text to be added to the
304 -- original undefined message noting "(more references follow)". The
305 -- full error list option (-gnatf) forces messages to be generated for
306 -- every reference and disconnects the use of this table.
308 type Uref_Entry
is record
310 -- Node for identifier for which original message was posted. The
311 -- Chars field of this identifier is used to detect later references
312 -- to the same identifier.
315 -- Records error message Id of original undefined message. Reset to
316 -- No_Error_Msg after the second occurrence, where it is used to add
317 -- text to the original message as described above.
320 -- Set if the message is not visible rather than undefined
323 -- Records location of error message. Used to make sure that we do
324 -- not consider a, b : undefined as two separate instances, which
325 -- would otherwise happen, since the parser converts this sequence
326 -- to a : undefined; b : undefined.
330 package Urefs
is new Table
.Table
(
331 Table_Component_Type
=> Uref_Entry
,
332 Table_Index_Type
=> Nat
,
333 Table_Low_Bound
=> 1,
335 Table_Increment
=> 100,
336 Table_Name
=> "Urefs");
338 Candidate_Renaming
: Entity_Id
;
339 -- Holds a candidate interpretation that appears in a subprogram renaming
340 -- declaration and does not match the given specification, but matches at
341 -- least on the first formal. Allows better error message when given
342 -- specification omits defaulted parameters, a common error.
344 -----------------------
345 -- Local Subprograms --
346 -----------------------
348 procedure Analyze_Generic_Renaming
351 -- Common processing for all three kinds of generic renaming declarations.
352 -- Enter new name and indicate that it renames the generic unit.
354 procedure Analyze_Renamed_Character
358 -- Renamed entity is given by a character literal, which must belong
359 -- to the return type of the new entity. Is_Body indicates whether the
360 -- declaration is a renaming_as_body. If the original declaration has
361 -- already been frozen (because of an intervening body, e.g.) the body of
362 -- the function must be built now. The same applies to the following
363 -- various renaming procedures.
365 procedure Analyze_Renamed_Dereference
369 -- Renamed entity is given by an explicit dereference. Prefix must be a
370 -- conformant access_to_subprogram type.
372 procedure Analyze_Renamed_Entry
376 -- If the renamed entity in a subprogram renaming is an entry or protected
377 -- subprogram, build a body for the new entity whose only statement is a
378 -- call to the renamed entity.
380 procedure Analyze_Renamed_Family_Member
384 -- Used when the renamed entity is an indexed component. The prefix must
385 -- denote an entry family.
387 procedure Attribute_Renaming
(N
: Node_Id
);
388 -- Analyze renaming of attribute as function. The renaming declaration N
389 -- is rewritten as a function body that returns the attribute reference
390 -- applied to the formals of the function.
392 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
);
393 -- A renaming_as_body may occur after the entity of the original decla-
394 -- ration has been frozen. In that case, the body of the new entity must
395 -- be built now, because the usual mechanism of building the renamed
396 -- body at the point of freezing will not work. Subp is the subprogram
397 -- for which N provides the Renaming_As_Body.
399 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
);
400 -- Verify that the entity in a renaming declaration that is a library unit
401 -- is itself a library unit and not a nested unit or subunit. Also check
402 -- that if the renaming is a child unit of a generic parent, then the
403 -- renamed unit must also be a child unit of that parent. Finally, verify
404 -- that a renamed generic unit is not an implicit child declared within
405 -- an instance of the parent.
407 procedure Chain_Use_Clause
(N
: Node_Id
);
408 -- Chain use clause onto list of uses clauses headed by First_Use_Clause
409 -- in the top scope table entry.
411 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean;
412 -- Find a type derived from Character or Wide_Character in the prefix of N.
413 -- Used to resolved qualified names whose selector is a character literal.
415 function Find_Renamed_Entity
419 Is_Actual
: Boolean := False) return Entity_Id
;
420 -- Find the renamed entity that corresponds to the given parameter profile
421 -- in a subprogram renaming declaration. The renamed entity may be an
422 -- operator, a subprogram, an entry, or a protected operation. Is_Actual
423 -- indicates that the renaming is the one generated for an actual subpro-
424 -- gram in an instance, for which special visibility checks apply.
426 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
);
427 -- A subprogram defined by a renaming declaration inherits the parameter
428 -- profile of the renamed entity. The subtypes given in the subprogram
429 -- specification are discarded and replaced with those of the renamed
430 -- subprogram, which are then used to recheck the default values.
432 procedure Premature_Usage
(N
: Node_Id
);
433 -- Diagnose usage of an entity before it is visible.
435 procedure Write_Info
;
436 -- Write debugging information on entities declared in current scope
438 procedure Write_Scopes
;
439 pragma Warnings
(Off
, Write_Scopes
);
440 -- Debugging information: dump all entities on scope stack
442 --------------------------------
443 -- Analyze_Exception_Renaming --
444 --------------------------------
446 -- The language only allows a single identifier, but the tree holds
447 -- an identifier list. The parser has already issued an error message
448 -- if there is more than one element in the list.
450 procedure Analyze_Exception_Renaming
(N
: Node_Id
) is
451 Id
: constant Node_Id
:= Defining_Identifier
(N
);
452 Nam
: constant Node_Id
:= Name
(N
);
458 Set_Ekind
(Id
, E_Exception
);
459 Set_Exception_Code
(Id
, Uint_0
);
460 Set_Etype
(Id
, Standard_Exception_Type
);
461 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
463 if not Is_Entity_Name
(Nam
) or else
464 Ekind
(Entity
(Nam
)) /= E_Exception
466 Error_Msg_N
("invalid exception name in renaming", Nam
);
468 if Present
(Renamed_Object
(Entity
(Nam
))) then
469 Set_Renamed_Object
(Id
, Renamed_Object
(Entity
(Nam
)));
471 Set_Renamed_Object
(Id
, Entity
(Nam
));
474 end Analyze_Exception_Renaming
;
476 ---------------------------
477 -- Analyze_Expanded_Name --
478 ---------------------------
480 procedure Analyze_Expanded_Name
(N
: Node_Id
) is
482 -- If the entity pointer is already set, this is an internal node, or
483 -- a node that is analyzed more than once, after a tree modification.
484 -- In such a case there is no resolution to perform, just set the type.
485 -- For completeness, analyze prefix as well.
487 if Present
(Entity
(N
)) then
488 if Is_Type
(Entity
(N
)) then
489 Set_Etype
(N
, Entity
(N
));
491 Set_Etype
(N
, Etype
(Entity
(N
)));
494 Analyze
(Prefix
(N
));
497 Find_Expanded_Name
(N
);
499 end Analyze_Expanded_Name
;
501 ----------------------------------------
502 -- Analyze_Generic_Function_Renaming --
503 ----------------------------------------
505 procedure Analyze_Generic_Function_Renaming
(N
: Node_Id
) is
507 Analyze_Generic_Renaming
(N
, E_Generic_Function
);
508 end Analyze_Generic_Function_Renaming
;
510 ---------------------------------------
511 -- Analyze_Generic_Package_Renaming --
512 ---------------------------------------
514 procedure Analyze_Generic_Package_Renaming
(N
: Node_Id
) is
516 -- Apply the Text_IO Kludge here, since we may be renaming
517 -- one of the subpackages of Text_IO, then join common routine.
519 Text_IO_Kludge
(Name
(N
));
521 Analyze_Generic_Renaming
(N
, E_Generic_Package
);
522 end Analyze_Generic_Package_Renaming
;
524 -----------------------------------------
525 -- Analyze_Generic_Procedure_Renaming --
526 -----------------------------------------
528 procedure Analyze_Generic_Procedure_Renaming
(N
: Node_Id
) is
530 Analyze_Generic_Renaming
(N
, E_Generic_Procedure
);
531 end Analyze_Generic_Procedure_Renaming
;
533 ------------------------------
534 -- Analyze_Generic_Renaming --
535 ------------------------------
537 procedure Analyze_Generic_Renaming
541 New_P
: Entity_Id
:= Defining_Entity
(N
);
543 Inst
: Boolean := False; -- prevent junk warning
546 if Name
(N
) = Error
then
550 Generate_Definition
(New_P
);
552 if Current_Scope
/= Standard_Standard
then
553 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
556 if Nkind
(Name
(N
)) = N_Selected_Component
then
557 Check_Generic_Child_Unit
(Name
(N
), Inst
);
562 if not Is_Entity_Name
(Name
(N
)) then
563 Error_Msg_N
("expect entity name in renaming declaration", Name
(N
));
566 Old_P
:= Entity
(Name
(N
));
570 Set_Ekind
(New_P
, K
);
572 if Etype
(Old_P
) = Any_Type
then
575 elsif Ekind
(Old_P
) /= K
then
576 Error_Msg_N
("invalid generic unit name", Name
(N
));
579 if Present
(Renamed_Object
(Old_P
)) then
580 Set_Renamed_Object
(New_P
, Renamed_Object
(Old_P
));
582 Set_Renamed_Object
(New_P
, Old_P
);
585 Set_Etype
(New_P
, Etype
(Old_P
));
586 Set_Has_Completion
(New_P
);
588 if In_Open_Scopes
(Old_P
) then
589 Error_Msg_N
("within its scope, generic denotes its instance", N
);
592 Check_Library_Unit_Renaming
(N
, Old_P
);
595 end Analyze_Generic_Renaming
;
597 -----------------------------
598 -- Analyze_Object_Renaming --
599 -----------------------------
601 procedure Analyze_Object_Renaming
(N
: Node_Id
) is
602 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
604 Nam
: constant Node_Id
:= Name
(N
);
605 S
: constant Entity_Id
:= Subtype_Mark
(N
);
614 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
617 -- The renaming of a component that depends on a discriminant
618 -- requires an actual subtype, because in subsequent use of the object
619 -- Gigi will be unable to locate the actual bounds. This explicit step
620 -- is required when the renaming is generated in removing side effects
621 -- of an already-analyzed expression.
623 if Nkind
(Nam
) = N_Selected_Component
624 and then Analyzed
(Nam
)
627 Dec
:= Build_Actual_Subtype_Of_Component
(Etype
(Nam
), Nam
);
629 if Present
(Dec
) then
630 Insert_Action
(N
, Dec
);
631 T
:= Defining_Identifier
(Dec
);
638 Analyze_And_Resolve
(Nam
, T
);
641 -- An object renaming requires an exact match of the type;
642 -- class-wide matching is not allowed.
644 if Is_Class_Wide_Type
(T
)
645 and then Base_Type
(Etype
(Nam
)) /= Base_Type
(T
)
651 Set_Ekind
(Id
, E_Variable
);
652 Init_Size_Align
(Id
);
654 if T
= Any_Type
or else Etype
(Nam
) = Any_Type
then
657 -- Verify that the renamed entity is an object or a function call.
658 -- It may have been rewritten in several ways.
660 elsif Is_Object_Reference
(Nam
) then
662 if Comes_From_Source
(N
)
663 and then Is_Dependent_Component_Of_Mutable_Object
(Nam
)
666 ("illegal renaming of discriminant-dependent component", Nam
);
671 -- A static function call may have been folded into a literal
673 elsif Nkind
(Original_Node
(Nam
)) = N_Function_Call
675 -- When expansion is disabled, attribute reference is not
676 -- rewritten as function call. Otherwise it may be rewritten
677 -- as a conversion, so check original node.
679 or else (Nkind
(Original_Node
(Nam
)) = N_Attribute_Reference
680 and then Is_Function_Attribute_Name
681 (Attribute_Name
(Original_Node
(Nam
))))
683 -- Weird but legal, equivalent to renaming a function call.
685 or else (Is_Entity_Name
(Nam
)
686 and then Ekind
(Entity
(Nam
)) = E_Enumeration_Literal
)
688 or else (Nkind
(Nam
) = N_Type_Conversion
689 and then Is_Tagged_Type
(Entity
(Subtype_Mark
(Nam
))))
694 if Nkind
(Nam
) = N_Type_Conversion
then
696 ("renaming of conversion only allowed for tagged types", Nam
);
699 Error_Msg_N
("expect object name in renaming", Nam
);
706 if not Is_Variable
(Nam
) then
707 Set_Ekind
(Id
, E_Constant
);
708 Set_Not_Source_Assigned
(Id
, True);
709 Set_Is_True_Constant
(Id
, True);
712 Set_Renamed_Object
(Id
, Nam
);
713 end Analyze_Object_Renaming
;
715 ------------------------------
716 -- Analyze_Package_Renaming --
717 ------------------------------
719 procedure Analyze_Package_Renaming
(N
: Node_Id
) is
720 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
725 if Name
(N
) = Error
then
729 -- Apply Text_IO kludge here, since we may be renaming one of
730 -- the children of Text_IO
732 Text_IO_Kludge
(Name
(N
));
734 if Current_Scope
/= Standard_Standard
then
735 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
740 if Is_Entity_Name
(Name
(N
)) then
741 Old_P
:= Entity
(Name
(N
));
746 if Etype
(Old_P
) = Any_Type
then
748 ("expect package name in renaming", Name
(N
));
750 elsif Ekind
(Old_P
) /= E_Package
751 and then not (Ekind
(Old_P
) = E_Generic_Package
752 and then In_Open_Scopes
(Old_P
))
754 if Ekind
(Old_P
) = E_Generic_Package
then
756 ("generic package cannot be renamed as a package", Name
(N
));
758 Error_Msg_Sloc
:= Sloc
(Old_P
);
760 ("expect package name in renaming, found& declared#",
764 -- Set basic attributes to minimize cascaded errors.
766 Set_Ekind
(New_P
, E_Package
);
767 Set_Etype
(New_P
, Standard_Void_Type
);
769 elsif Ekind
(Old_P
) = E_Package
770 and then From_With_Type
(Old_P
)
772 Error_Msg_N
("imported package cannot be renamed", Name
(N
));
775 -- Entities in the old package are accessible through the
776 -- renaming entity. The simplest implementation is to have
777 -- both packages share the entity list.
779 Set_Ekind
(New_P
, E_Package
);
780 Set_Etype
(New_P
, Standard_Void_Type
);
782 if Present
(Renamed_Object
(Old_P
)) then
783 Set_Renamed_Object
(New_P
, Renamed_Object
(Old_P
));
785 Set_Renamed_Object
(New_P
, Old_P
);
788 Set_Has_Completion
(New_P
);
790 Set_First_Entity
(New_P
, First_Entity
(Old_P
));
791 Set_Last_Entity
(New_P
, Last_Entity
(Old_P
));
792 Set_First_Private_Entity
(New_P
, First_Private_Entity
(Old_P
));
793 Check_Library_Unit_Renaming
(N
, Old_P
);
794 Generate_Reference
(Old_P
, Name
(N
));
796 -- If this is the renaming declaration of a package instantiation
797 -- within itself, it is the declaration that ends the list of actuals
798 -- for the instantiation. At this point, the subtypes that rename
799 -- the actuals are flagged as generic, to avoid spurious ambiguities
800 -- if the actuals for two distinct formals happen to coincide. If
801 -- the actual is a private type, the subtype has a private completion
802 -- that is flagged in the same fashion.
804 -- Resolution is identical to what is was in the original generic.
805 -- On exit from the generic instance, these are turned into regular
806 -- subtypes again, so they are compatible with types in their class.
808 if not Is_Generic_Instance
(Old_P
) then
811 Spec
:= Specification
(Unit_Declaration_Node
(Old_P
));
814 if Nkind
(Spec
) = N_Package_Specification
815 and then Present
(Generic_Parent
(Spec
))
816 and then Old_P
= Current_Scope
817 and then Chars
(New_P
) = Chars
(Generic_Parent
(Spec
))
820 E
: Entity_Id
:= First_Entity
(Old_P
);
826 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
828 Set_Is_Generic_Actual_Type
(E
);
830 if Is_Private_Type
(E
)
831 and then Present
(Full_View
(E
))
833 Set_Is_Generic_Actual_Type
(Full_View
(E
));
843 end Analyze_Package_Renaming
;
845 -------------------------------
846 -- Analyze_Renamed_Character --
847 -------------------------------
849 procedure Analyze_Renamed_Character
854 C
: constant Node_Id
:= Name
(N
);
857 if Ekind
(New_S
) = E_Function
then
858 Resolve
(C
, Etype
(New_S
));
861 Check_Frozen_Renaming
(N
, New_S
);
865 Error_Msg_N
("character literal can only be renamed as function", N
);
867 end Analyze_Renamed_Character
;
869 ---------------------------------
870 -- Analyze_Renamed_Dereference --
871 ---------------------------------
873 procedure Analyze_Renamed_Dereference
878 Nam
: constant Node_Id
:= Name
(N
);
879 P
: constant Node_Id
:= Prefix
(Nam
);
885 if not Is_Overloaded
(P
) then
887 if Ekind
(Etype
(Nam
)) /= E_Subprogram_Type
888 or else not Type_Conformant
(Etype
(Nam
), New_S
) then
889 Error_Msg_N
("designated type does not match specification", P
);
891 Resolve
(P
, Etype
(P
));
898 Get_First_Interp
(Nam
, I
, It
);
900 while Present
(It
.Nam
) loop
902 if Ekind
(It
.Nam
) = E_Subprogram_Type
903 and then Type_Conformant
(It
.Nam
, New_S
) then
905 if Typ
/= Any_Id
then
906 Error_Msg_N
("ambiguous renaming", P
);
913 Get_Next_Interp
(I
, It
);
916 if Typ
= Any_Type
then
917 Error_Msg_N
("designated type does not match specification", P
);
922 Check_Frozen_Renaming
(N
, New_S
);
926 end Analyze_Renamed_Dereference
;
928 ---------------------------
929 -- Analyze_Renamed_Entry --
930 ---------------------------
932 procedure Analyze_Renamed_Entry
937 Nam
: Node_Id
:= Name
(N
);
938 Sel
: Node_Id
:= Selector_Name
(Nam
);
942 if Entity
(Sel
) = Any_Id
then
944 -- Selector is undefined on prefix. Error emitted already.
946 Set_Has_Completion
(New_S
);
950 -- Otherwise, find renamed entity, and build body of New_S as a call
953 Old_S
:= Find_Renamed_Entity
(N
, Selector_Name
(Nam
), New_S
);
955 if Old_S
= Any_Id
then
956 Error_Msg_N
(" no subprogram or entry matches specification", N
);
959 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
960 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
961 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
964 Inherit_Renamed_Profile
(New_S
, Old_S
);
967 Set_Convention
(New_S
, Convention
(Old_S
));
968 Set_Has_Completion
(New_S
, Inside_A_Generic
);
971 Check_Frozen_Renaming
(N
, New_S
);
973 end Analyze_Renamed_Entry
;
975 -----------------------------------
976 -- Analyze_Renamed_Family_Member --
977 -----------------------------------
979 procedure Analyze_Renamed_Family_Member
984 Nam
: Node_Id
:= Name
(N
);
985 P
: Node_Id
:= Prefix
(Nam
);
989 if (Is_Entity_Name
(P
) and then Ekind
(Entity
(P
)) = E_Entry_Family
)
990 or else (Nkind
(P
) = N_Selected_Component
992 Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
)
994 if Is_Entity_Name
(P
) then
997 Old_S
:= Entity
(Selector_Name
(P
));
1000 if not Entity_Matches_Spec
(Old_S
, New_S
) then
1001 Error_Msg_N
("entry family does not match specification", N
);
1004 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1005 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1006 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1009 Error_Msg_N
("no entry family matches specification", N
);
1012 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1015 Check_Frozen_Renaming
(N
, New_S
);
1017 end Analyze_Renamed_Family_Member
;
1019 ---------------------------------
1020 -- Analyze_Subprogram_Renaming --
1021 ---------------------------------
1023 procedure Analyze_Subprogram_Renaming
(N
: Node_Id
) is
1024 Nam
: Node_Id
:= Name
(N
);
1025 Spec
: constant Node_Id
:= Specification
(N
);
1027 Old_S
: Entity_Id
:= Empty
;
1028 Rename_Spec
: Entity_Id
;
1029 Is_Actual
: Boolean := False;
1030 Inst_Node
: Node_Id
:= Empty
;
1031 Save_83
: Boolean := Ada_83
;
1033 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
;
1034 -- Find renamed entity when the declaration is a renaming_as_body
1035 -- and the renamed entity may itself be a renaming_as_body. Used to
1036 -- enforce rule that a renaming_as_body is illegal if the declaration
1037 -- occurs before the subprogram it completes is frozen, and renaming
1038 -- indirectly renames the subprogram itself.(Defect Report 8652/0027).
1040 -------------------------
1041 -- Original_Subprogram --
1042 -------------------------
1044 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
is
1045 Orig_Decl
: Node_Id
;
1046 Orig_Subp
: Entity_Id
;
1049 -- First case: renamed entity is itself a renaming
1051 if Present
(Alias
(Subp
)) then
1052 return Alias
(Subp
);
1055 Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
1057 (Corresponding_Body
(Unit_Declaration_Node
(Subp
)))
1059 -- Check if renamed entity is a renaming_as_body
1062 Unit_Declaration_Node
1063 (Corresponding_Body
(Unit_Declaration_Node
(Subp
)));
1065 if Nkind
(Orig_Decl
) = N_Subprogram_Renaming_Declaration
then
1066 Orig_Subp
:= Entity
(Name
(Orig_Decl
));
1068 if Orig_Subp
= Rename_Spec
then
1070 -- Circularity detected.
1075 return (Original_Subprogram
(Orig_Subp
));
1083 end Original_Subprogram
;
1085 -- Start of procesing for Analyze_Subprogram_Renaming
1088 -- We must test for the attribute renaming case before the Analyze
1089 -- call because otherwise Sem_Attr will complain that the attribute
1090 -- is missing an argument when it is analyzed.
1092 if Nkind
(Nam
) = N_Attribute_Reference
then
1093 Attribute_Renaming
(N
);
1097 -- Check whether this declaration corresponds to the instantiation
1098 -- of a formal subprogram. This is indicated by the presence of a
1099 -- Corresponding_Spec that is the instantiation declaration.
1101 -- If this is an instantiation, the corresponding actual is frozen
1102 -- and error messages can be made more precise. If this is a default
1103 -- subprogram, the entity is already established in the generic, and
1104 -- is not retrieved by visibility. If it is a default with a box, the
1105 -- candidate interpretations, if any, have been collected when building
1106 -- the renaming declaration. If overloaded, the proper interpretation
1107 -- is determined in Find_Renamed_Entity. If the entity is an operator,
1108 -- Find_Renamed_Entity applies additional visibility checks.
1110 if Present
(Corresponding_Spec
(N
)) then
1112 Inst_Node
:= Corresponding_Spec
(N
);
1114 if Is_Entity_Name
(Nam
)
1115 and then Present
(Entity
(Nam
))
1116 and then not Comes_From_Source
(Nam
)
1117 and then not Is_Overloaded
(Nam
)
1119 Old_S
:= Entity
(Nam
);
1120 New_S
:= Analyze_Spec
(Spec
);
1122 if Ekind
(Entity
(Nam
)) = E_Operator
1123 and then Box_Present
(Corresponding_Spec
(N
))
1125 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
1130 New_S
:= Analyze_Spec
(Spec
);
1133 Set_Corresponding_Spec
(N
, Empty
);
1136 -- Renamed entity must be analyzed first, to avoid being hidden by
1137 -- new name (which might be the same in a generic instance).
1141 -- The renaming defines a new overloaded entity, which is analyzed
1142 -- like a subprogram declaration.
1144 New_S
:= Analyze_Spec
(Spec
);
1147 if Current_Scope
/= Standard_Standard
then
1148 Set_Is_Pure
(New_S
, Is_Pure
(Current_Scope
));
1151 Rename_Spec
:= Find_Corresponding_Spec
(N
);
1153 if Present
(Rename_Spec
) then
1155 -- Renaming_As_Body. Renaming declaration is the completion of
1156 -- the declaration of Rename_Spec. We will build an actual body
1157 -- for it at the freezing point.
1159 Set_Corresponding_Spec
(N
, Rename_Spec
);
1160 Set_Corresponding_Body
(Unit_Declaration_Node
(Rename_Spec
), New_S
);
1162 -- The body is created when the entity is frozen. If the context
1163 -- is generic, freeze_all is not invoked, so we need to indicate
1164 -- that the entity has a completion.
1166 Set_Has_Completion
(Rename_Spec
, Inside_A_Generic
);
1168 if Ada_83
and then Comes_From_Source
(N
) then
1169 Error_Msg_N
("(Ada 83) renaming cannot serve as a body", N
);
1172 Set_Convention
(New_S
, Convention
(Rename_Spec
));
1173 Check_Fully_Conformant
(New_S
, Rename_Spec
);
1174 Set_Public_Status
(New_S
);
1176 -- Indicate that the entity in the declaration functions like
1177 -- the corresponding body, and is not a new entity.
1179 Set_Ekind
(New_S
, E_Subprogram_Body
);
1180 New_S
:= Rename_Spec
;
1183 Generate_Definition
(New_S
);
1184 New_Overloaded_Entity
(New_S
);
1185 if Is_Entity_Name
(Nam
)
1186 and then Is_Intrinsic_Subprogram
(Entity
(Nam
))
1190 Check_Delayed_Subprogram
(New_S
);
1194 -- There is no need for elaboration checks on the new entity, which
1195 -- may be called before the next freezing point where the body will
1198 Set_Suppress_Elaboration_Checks
(New_S
, True);
1200 if Etype
(Nam
) = Any_Type
then
1201 Set_Has_Completion
(New_S
);
1204 elsif Nkind
(Nam
) = N_Selected_Component
then
1206 -- Renamed entity is an entry or protected subprogram. For those
1207 -- cases an explicit body is built (at the point of freezing of
1208 -- this entity) that contains a call to the renamed entity.
1210 Analyze_Renamed_Entry
(N
, New_S
, Present
(Rename_Spec
));
1213 elsif Nkind
(Nam
) = N_Explicit_Dereference
then
1215 -- Renamed entity is designated by access_to_subprogram expression.
1216 -- Must build body to encapsulate call, as in the entry case.
1218 Analyze_Renamed_Dereference
(N
, New_S
, Present
(Rename_Spec
));
1221 elsif Nkind
(Nam
) = N_Indexed_Component
then
1222 Analyze_Renamed_Family_Member
(N
, New_S
, Present
(Rename_Spec
));
1225 elsif Nkind
(Nam
) = N_Character_Literal
then
1226 Analyze_Renamed_Character
(N
, New_S
, Present
(Rename_Spec
));
1229 elsif (not Is_Entity_Name
(Nam
)
1230 and then Nkind
(Nam
) /= N_Operator_Symbol
)
1231 or else not Is_Overloadable
(Entity
(Nam
))
1233 Error_Msg_N
("expect valid subprogram name in renaming", N
);
1238 -- Most common case: subprogram renames subprogram. No body is
1239 -- generated in this case, so we must indicate that the declaration
1240 -- is complete as is.
1242 if No
(Rename_Spec
) then
1243 Set_Has_Completion
(New_S
);
1246 -- Find the renamed entity that matches the given specification.
1247 -- Disable Ada_83 because there is no requirement of full conformance
1248 -- between renamed entity and new entity, even though the same circuit
1254 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
1257 if Old_S
/= Any_Id
then
1260 and then Box_Present
(Inst_Node
)
1262 -- This is an implicit reference to the default actual
1264 Generate_Reference
(Old_S
, Nam
, Typ
=> 'i', Force
=> True);
1266 Generate_Reference
(Old_S
, Nam
);
1269 -- For a renaming-as-body, require subtype conformance,
1270 -- but if the declaration being completed has not been
1271 -- frozen, then inherit the convention of the renamed
1272 -- subprogram prior to checking conformance (unless the
1273 -- renaming has an explicit convention established; the
1274 -- rule stated in the RM doesn't seem to address this ???).
1276 if Present
(Rename_Spec
) then
1277 Generate_Reference
(Rename_Spec
, Defining_Entity
(Spec
), 'b');
1278 Style
.Check_Identifier
(Defining_Entity
(Spec
), Rename_Spec
);
1280 if not Is_Frozen
(Rename_Spec
) then
1281 if not Has_Convention_Pragma
(Rename_Spec
) then
1282 Set_Convention
(New_S
, Convention
(Old_S
));
1285 if Ekind
(Old_S
) /= E_Operator
then
1286 Check_Mode_Conformant
(New_S
, Old_S
, Spec
);
1289 if Original_Subprogram
(Old_S
) = Rename_Spec
then
1290 Error_Msg_N
("unfrozen subprogram cannot rename itself ", N
);
1293 Check_Subtype_Conformant
(New_S
, Old_S
, Spec
);
1296 Check_Frozen_Renaming
(N
, Rename_Spec
);
1298 elsif Ekind
(Old_S
) /= E_Operator
then
1299 Check_Mode_Conformant
(New_S
, Old_S
);
1302 and then Error_Posted
(New_S
)
1304 Error_Msg_NE
("invalid actual subprogram: & #!", N
, Old_S
);
1308 if No
(Rename_Spec
) then
1310 -- The parameter profile of the new entity is that of the renamed
1311 -- entity: the subtypes given in the specification are irrelevant.
1313 Inherit_Renamed_Profile
(New_S
, Old_S
);
1315 -- A call to the subprogram is transformed into a call to the
1316 -- renamed entity. This is transitive if the renamed entity is
1317 -- itself a renaming.
1319 if Present
(Alias
(Old_S
)) then
1320 Set_Alias
(New_S
, Alias
(Old_S
));
1322 Set_Alias
(New_S
, Old_S
);
1325 -- Note that we do not set Is_Instrinsic_Subprogram if we have
1326 -- a renaming as body, since the entity in this case is not an
1327 -- intrinsic (it calls an intrinsic, but we have a real body
1328 -- for this call, and it is in this body that the required
1329 -- intrinsic processing will take place).
1331 Set_Is_Intrinsic_Subprogram
1332 (New_S
, Is_Intrinsic_Subprogram
(Old_S
));
1334 if Ekind
(Alias
(New_S
)) = E_Operator
then
1335 Set_Has_Delayed_Freeze
(New_S
, False);
1341 and then (Old_S
= New_S
1342 or else (Nkind
(Nam
) /= N_Expanded_Name
1343 and then Chars
(Old_S
) = Chars
(New_S
)))
1345 Error_Msg_N
("subprogram cannot rename itself", N
);
1348 Set_Convention
(New_S
, Convention
(Old_S
));
1349 Set_Is_Abstract
(New_S
, Is_Abstract
(Old_S
));
1350 Check_Library_Unit_Renaming
(N
, Old_S
);
1352 -- Pathological case: procedure renames entry in the scope of
1353 -- its task. Entry is given by simple name, but body must be built
1354 -- for procedure. Of course if called it will deadlock.
1356 if Ekind
(Old_S
) = E_Entry
then
1357 Set_Has_Completion
(New_S
, False);
1358 Set_Alias
(New_S
, Empty
);
1362 Freeze_Before
(N
, Old_S
);
1363 Set_Has_Delayed_Freeze
(New_S
, False);
1364 Freeze_Before
(N
, New_S
);
1366 if (Ekind
(Old_S
) = E_Procedure
or else Ekind
(Old_S
) = E_Function
)
1367 and then Is_Abstract
(Old_S
)
1370 ("abstract subprogram not allowed as generic actual", Nam
);
1375 -- A common error is to assume that implicit operators for types
1376 -- are defined in Standard, or in the scope of a subtype. In those
1377 -- cases where the renamed entity is given with an expanded name,
1378 -- it is worth mentioning that operators for the type are not
1379 -- declared in the scope given by the prefix.
1381 if Nkind
(Nam
) = N_Expanded_Name
1382 and then Nkind
(Selector_Name
(Nam
)) = N_Operator_Symbol
1383 and then Scope
(Entity
(Nam
)) = Standard_Standard
1386 T
: constant Entity_Id
:=
1387 Base_Type
(Etype
(First_Formal
(New_S
)));
1390 Error_Msg_Node_2
:= Prefix
(Nam
);
1391 Error_Msg_NE
("\operator for type& is not declared in&",
1396 ("no visible subprogram matches the specification for&",
1400 if Present
(Candidate_Renaming
) then
1406 F1
:= First_Formal
(Candidate_Renaming
);
1407 F2
:= First_Formal
(New_S
);
1409 while Present
(F1
) and then Present
(F2
) loop
1414 if Present
(F1
) and then Present
(Default_Value
(F1
)) then
1415 if Present
(Next_Formal
(F1
)) then
1417 ("\missing specification for &" &
1418 " and other formals with defaults", Spec
, F1
);
1421 ("\missing specification for &", Spec
, F1
);
1429 end Analyze_Subprogram_Renaming
;
1431 -------------------------
1432 -- Analyze_Use_Package --
1433 -------------------------
1435 -- Resolve the package names in the use clause, and make all the visible
1436 -- entities defined in the package potentially use-visible. If the package
1437 -- is already in use from a previous use clause, its visible entities are
1438 -- already use-visible. In that case, mark the occurrence as a redundant
1439 -- use. If the package is an open scope, i.e. if the use clause occurs
1440 -- within the package itself, ignore it.
1442 procedure Analyze_Use_Package
(N
: Node_Id
) is
1443 Pack_Name
: Node_Id
;
1446 function In_Previous_With_Clause
return Boolean;
1447 -- For use clauses in a context clause, the indicated package may
1448 -- be visible and yet illegal, if it did not appear in a previous
1451 -----------------------------
1452 -- In_Previous_With_Clause --
1453 -----------------------------
1455 function In_Previous_With_Clause
return Boolean is
1459 Item
:= First
(Context_Items
(Parent
(N
)));
1461 while Present
(Item
)
1464 if Nkind
(Item
) = N_With_Clause
1465 and then Entity
(Name
(Item
)) = Pack
1474 end In_Previous_With_Clause
;
1476 -- Start of processing for Analyze_Use_Package
1479 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
1481 -- Use clause is not allowed in a spec of a predefined package
1482 -- declaration except that packages whose file name starts a-n
1483 -- are OK (these are children of Ada.Numerics, and such packages
1484 -- are never loaded by Rtsfind).
1486 if Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
1487 and then Name_Buffer
(1 .. 3) /= "a-n"
1489 Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
1491 Error_Msg_N
("use clause not allowed in predefined spec", N
);
1494 -- Chain clause to list of use clauses in current scope.
1496 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
1497 Chain_Use_Clause
(N
);
1500 -- Loop through package names to identify referenced packages
1502 Pack_Name
:= First
(Names
(N
));
1504 while Present
(Pack_Name
) loop
1505 Analyze
(Pack_Name
);
1507 if Nkind
(Parent
(N
)) = N_Compilation_Unit
1508 and then Nkind
(Pack_Name
) = N_Expanded_Name
1511 Pref
: Node_Id
:= Prefix
(Pack_Name
);
1514 while Nkind
(Pref
) = N_Expanded_Name
loop
1515 Pref
:= Prefix
(Pref
);
1518 if Entity
(Pref
) = Standard_Standard
then
1520 ("predefined package Standard cannot appear"
1521 & " in a context clause", Pref
);
1529 -- Loop through package names to mark all entities as potentially
1532 Pack_Name
:= First
(Names
(N
));
1534 while Present
(Pack_Name
) loop
1536 if Is_Entity_Name
(Pack_Name
) then
1537 Pack
:= Entity
(Pack_Name
);
1539 if Ekind
(Pack
) /= E_Package
1540 and then Etype
(Pack
) /= Any_Type
1542 if Ekind
(Pack
) = E_Generic_Package
then
1544 ("a generic package is not allowed in a use clause",
1547 Error_Msg_N
("& is not a usable package", Pack_Name
);
1550 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
1551 and then Nkind
(Pack_Name
) /= N_Expanded_Name
1552 and then not In_Previous_With_Clause
1554 Error_Msg_N
("package is not directly visible", Pack_Name
);
1556 elsif Applicable_Use
(Pack_Name
) then
1557 Use_One_Package
(Pack
, N
);
1564 end Analyze_Use_Package
;
1566 ----------------------
1567 -- Analyze_Use_Type --
1568 ----------------------
1570 procedure Analyze_Use_Type
(N
: Node_Id
) is
1574 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
1576 -- Chain clause to list of use clauses in current scope.
1578 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
1579 Chain_Use_Clause
(N
);
1582 Id
:= First
(Subtype_Marks
(N
));
1584 while Present
(Id
) loop
1587 if Entity
(Id
) /= Any_Type
then
1593 end Analyze_Use_Type
;
1595 --------------------
1596 -- Applicable_Use --
1597 --------------------
1599 function Applicable_Use
(Pack_Name
: Node_Id
) return Boolean is
1600 Pack
: constant Entity_Id
:= Entity
(Pack_Name
);
1603 if In_Open_Scopes
(Pack
) then
1606 elsif In_Use
(Pack
) then
1607 Set_Redundant_Use
(Pack_Name
, True);
1610 elsif Present
(Renamed_Object
(Pack
))
1611 and then In_Use
(Renamed_Object
(Pack
))
1613 Set_Redundant_Use
(Pack_Name
, True);
1621 ------------------------
1622 -- Attribute_Renaming --
1623 ------------------------
1625 procedure Attribute_Renaming
(N
: Node_Id
) is
1626 Loc
: constant Source_Ptr
:= Sloc
(N
);
1627 Nam
: constant Node_Id
:= Name
(N
);
1628 Spec
: constant Node_Id
:= Specification
(N
);
1629 New_S
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
1630 Aname
: constant Name_Id
:= Attribute_Name
(Nam
);
1632 Form_Num
: Nat
:= 0;
1633 Expr_List
: List_Id
:= No_List
;
1635 Attr_Node
: Node_Id
;
1636 Body_Node
: Node_Id
;
1637 Param_Spec
: Node_Id
;
1640 Generate_Definition
(New_S
);
1642 -- This procedure is called in the context of subprogram renaming,
1643 -- and thus the attribute must be one that is a subprogram. All of
1644 -- those have at least one formal parameter, with the singular
1645 -- exception of AST_Entry (which is a real oddity, it is odd that
1646 -- this can be renamed at all!)
1648 if not Is_Non_Empty_List
(Parameter_Specifications
(Spec
)) then
1649 if Aname
/= Name_AST_Entry
then
1651 ("subprogram renaming an attribute must have formals", N
);
1656 Param_Spec
:= First
(Parameter_Specifications
(Spec
));
1658 while Present
(Param_Spec
) loop
1659 Form_Num
:= Form_Num
+ 1;
1661 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
1662 Find_Type
(Parameter_Type
(Param_Spec
));
1664 -- The profile of the new entity denotes the base type (s) of
1665 -- the types given in the specification. For access parameters
1666 -- there are no subtypes involved.
1668 Rewrite
(Parameter_Type
(Param_Spec
),
1670 (Base_Type
(Entity
(Parameter_Type
(Param_Spec
))), Loc
));
1673 if No
(Expr_List
) then
1674 Expr_List
:= New_List
;
1677 Append_To
(Expr_List
,
1678 Make_Identifier
(Loc
,
1679 Chars
=> Chars
(Defining_Identifier
(Param_Spec
))));
1685 -- Immediate error if too many formals. Other mismatches in numbers
1686 -- of number of types of parameters are detected when we analyze the
1687 -- body of the subprogram that we construct.
1689 if Form_Num
> 2 then
1690 Error_Msg_N
("too many formals for attribute", N
);
1693 Aname
= Name_Compose
or else
1694 Aname
= Name_Exponent
or else
1695 Aname
= Name_Leading_Part
or else
1696 Aname
= Name_Pos
or else
1697 Aname
= Name_Round
or else
1698 Aname
= Name_Scaling
or else
1701 if Nkind
(N
) = N_Subprogram_Renaming_Declaration
1702 and then Present
(Corresponding_Spec
(N
))
1703 and then Nkind
(Corresponding_Spec
(N
)) =
1704 N_Formal_Subprogram_Declaration
1707 ("generic actual cannot be attribute involving universal type",
1711 ("attribute involving a universal type cannot be renamed",
1716 -- AST_Entry is an odd case. It doesn't really make much sense to
1717 -- allow it to be renamed, but that's the DEC rule, so we have to
1718 -- do it right. The point is that the AST_Entry call should be made
1719 -- now, and what the function will return is the returned value.
1721 -- Note that there is no Expr_List in this case anyway
1723 if Aname
= Name_AST_Entry
then
1730 Ent
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
1733 Make_Object_Declaration
(Loc
,
1734 Defining_Identifier
=> Ent
,
1735 Object_Definition
=>
1736 New_Occurrence_Of
(RTE
(RE_AST_Handler
), Loc
),
1738 Constant_Present
=> True);
1740 Set_Assignment_OK
(Decl
, True);
1741 Insert_Action
(N
, Decl
);
1742 Attr_Node
:= Make_Identifier
(Loc
, Chars
(Ent
));
1745 -- For all other attributes, we rewrite the attribute node to have
1746 -- a list of expressions corresponding to the subprogram formals.
1747 -- A renaming declaration is not a freeze point, and the analysis of
1748 -- the attribute reference should not freeze the type of the prefix.
1752 Make_Attribute_Reference
(Loc
,
1753 Prefix
=> Prefix
(Nam
),
1754 Attribute_Name
=> Aname
,
1755 Expressions
=> Expr_List
);
1757 Set_Must_Not_Freeze
(Attr_Node
);
1758 Set_Must_Not_Freeze
(Prefix
(Nam
));
1761 -- Case of renaming a function
1763 if Nkind
(Spec
) = N_Function_Specification
then
1765 if Is_Procedure_Attribute_Name
(Aname
) then
1766 Error_Msg_N
("attribute can only be renamed as procedure", Nam
);
1770 Find_Type
(Subtype_Mark
(Spec
));
1771 Rewrite
(Subtype_Mark
(Spec
),
1772 New_Reference_To
(Base_Type
(Entity
(Subtype_Mark
(Spec
))), Loc
));
1775 Make_Subprogram_Body
(Loc
,
1776 Specification
=> Spec
,
1777 Declarations
=> New_List
,
1778 Handled_Statement_Sequence
=>
1779 Make_Handled_Sequence_Of_Statements
(Loc
,
1780 Statements
=> New_List
(
1781 Make_Return_Statement
(Loc
,
1782 Expression
=> Attr_Node
))));
1784 -- Case of renaming a procedure
1787 if not Is_Procedure_Attribute_Name
(Aname
) then
1788 Error_Msg_N
("attribute can only be renamed as function", Nam
);
1793 Make_Subprogram_Body
(Loc
,
1794 Specification
=> Spec
,
1795 Declarations
=> New_List
,
1796 Handled_Statement_Sequence
=>
1797 Make_Handled_Sequence_Of_Statements
(Loc
,
1798 Statements
=> New_List
(Attr_Node
)));
1801 Rewrite
(N
, Body_Node
);
1804 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
1806 -- We suppress elaboration warnings for the resulting entity, since
1807 -- clearly they are not needed, and more particularly, in the case
1808 -- of a generic formal subprogram, the resulting entity can appear
1809 -- after the instantiation itself, and thus look like a bogus case
1810 -- of access before elaboration.
1812 Set_Suppress_Elaboration_Warnings
(New_S
);
1814 end Attribute_Renaming
;
1816 ----------------------
1817 -- Chain_Use_Clause --
1818 ----------------------
1820 procedure Chain_Use_Clause
(N
: Node_Id
) is
1822 Set_Next_Use_Clause
(N
,
1823 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
);
1824 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
:= N
;
1825 end Chain_Use_Clause
;
1827 ----------------------------
1828 -- Check_Frozen_Renaming --
1829 ----------------------------
1831 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
) is
1837 and then not Has_Completion
(Subp
)
1841 (Parent
(Declaration_Node
(Subp
)), Defining_Entity
(N
));
1843 if Is_Entity_Name
(Name
(N
)) then
1844 Old_S
:= Entity
(Name
(N
));
1846 if not Is_Frozen
(Old_S
) then
1847 Ensure_Freeze_Node
(Old_S
);
1848 if No
(Actions
(Freeze_Node
(Old_S
))) then
1849 Set_Actions
(Freeze_Node
(Old_S
), New_List
(B_Node
));
1851 Append
(B_Node
, Actions
(Freeze_Node
(Old_S
)));
1854 Insert_After
(N
, B_Node
);
1858 if Is_Intrinsic_Subprogram
(Old_S
)
1859 and then not In_Instance
1862 ("subprogram used in renaming_as_body cannot be intrinsic",
1867 Insert_After
(N
, B_Node
);
1871 end Check_Frozen_Renaming
;
1873 ---------------------------------
1874 -- Check_Library_Unit_Renaming --
1875 ---------------------------------
1877 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
) is
1881 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
1884 elsif Scope
(Old_E
) /= Standard_Standard
1885 and then not Is_Child_Unit
(Old_E
)
1887 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
1889 elsif Present
(Parent_Spec
(N
))
1890 and then Nkind
(Unit
(Parent_Spec
(N
))) = N_Generic_Package_Declaration
1891 and then not Is_Child_Unit
(Old_E
)
1894 ("renamed unit must be a child unit of generic parent", Name
(N
));
1896 elsif Nkind
(N
) in N_Generic_Renaming_Declaration
1897 and then Nkind
(Name
(N
)) = N_Expanded_Name
1898 and then Is_Generic_Instance
(Entity
(Prefix
(Name
(N
))))
1899 and then Is_Generic_Unit
(Old_E
)
1902 ("renamed generic unit must be a library unit", Name
(N
));
1904 elsif Ekind
(Old_E
) = E_Package
1905 or else Ekind
(Old_E
) = E_Generic_Package
1907 -- Inherit categorization flags
1909 New_E
:= Defining_Entity
(N
);
1910 Set_Is_Pure
(New_E
, Is_Pure
(Old_E
));
1911 Set_Is_Preelaborated
(New_E
, Is_Preelaborated
(Old_E
));
1912 Set_Is_Remote_Call_Interface
(New_E
,
1913 Is_Remote_Call_Interface
(Old_E
));
1914 Set_Is_Remote_Types
(New_E
, Is_Remote_Types
(Old_E
));
1915 Set_Is_Shared_Passive
(New_E
, Is_Shared_Passive
(Old_E
));
1917 end Check_Library_Unit_Renaming
;
1923 procedure End_Scope
is
1929 Id
:= First_Entity
(Current_Scope
);
1931 while Present
(Id
) loop
1932 -- An entity in the current scope is not necessarily the first one
1933 -- on its homonym chain. Find its predecessor if any,
1934 -- If it is an internal entity, it will not be in the visibility
1935 -- chain altogether, and there is nothing to unchain.
1937 if Id
/= Current_Entity
(Id
) then
1938 Prev
:= Current_Entity
(Id
);
1939 while Present
(Prev
)
1940 and then Present
(Homonym
(Prev
))
1941 and then Homonym
(Prev
) /= Id
1943 Prev
:= Homonym
(Prev
);
1946 -- Skip to end of loop if Id is not in the visibility chain
1948 if No
(Prev
) or else Homonym
(Prev
) /= Id
then
1956 Outer
:= Homonym
(Id
);
1957 Set_Is_Immediately_Visible
(Id
, False);
1959 while Present
(Outer
) and then Scope
(Outer
) = Current_Scope
loop
1960 Outer
:= Homonym
(Outer
);
1963 -- Reset homonym link of other entities, but do not modify link
1964 -- between entities in current scope, so that the back-end can have
1965 -- a proper count of local overloadings.
1968 Set_Name_Entity_Id
(Chars
(Id
), Outer
);
1970 elsif Scope
(Prev
) /= Scope
(Id
) then
1971 Set_Homonym
(Prev
, Outer
);
1978 -- If the scope generated freeze actions, place them before the
1979 -- current declaration and analyze them. Type declarations and
1980 -- the bodies of initialization procedures can generate such nodes.
1981 -- We follow the parent chain until we reach a list node, which is
1982 -- the enclosing list of declarations. If the list appears within
1983 -- a protected definition, move freeze nodes outside the protected
1987 (Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
)
1991 L
: constant List_Id
:= Scope_Stack
.Table
1992 (Scope_Stack
.Last
).Pending_Freeze_Actions
;
1995 if Is_Itype
(Current_Scope
) then
1996 Decl
:= Associated_Node_For_Itype
(Current_Scope
);
1998 Decl
:= Parent
(Current_Scope
);
2003 while not (Is_List_Member
(Decl
))
2004 or else Nkind
(Parent
(Decl
)) = N_Protected_Definition
2005 or else Nkind
(Parent
(Decl
)) = N_Task_Definition
2007 Decl
:= Parent
(Decl
);
2010 Insert_List_Before_And_Analyze
(Decl
, L
);
2019 ---------------------
2020 -- End_Use_Clauses --
2021 ---------------------
2023 procedure End_Use_Clauses
(Clause
: Node_Id
) is
2024 U
: Node_Id
:= Clause
;
2027 while Present
(U
) loop
2028 if Nkind
(U
) = N_Use_Package_Clause
then
2029 End_Use_Package
(U
);
2030 elsif Nkind
(U
) = N_Use_Type_Clause
then
2034 Next_Use_Clause
(U
);
2036 end End_Use_Clauses
;
2038 ---------------------
2039 -- End_Use_Package --
2040 ---------------------
2042 procedure End_Use_Package
(N
: Node_Id
) is
2043 Pack_Name
: Node_Id
;
2049 Pack_Name
:= First
(Names
(N
));
2051 while Present
(Pack_Name
) loop
2052 Pack
:= Entity
(Pack_Name
);
2054 if Ekind
(Pack
) = E_Package
then
2056 if In_Open_Scopes
(Pack
) then
2059 elsif not Redundant_Use
(Pack_Name
) then
2060 Set_In_Use
(Pack
, False);
2061 Id
:= First_Entity
(Pack
);
2063 while Present
(Id
) loop
2065 -- Preserve use-visibility of operators whose formals have
2066 -- a type that is use_visible thanks to a previous use_type
2069 if Nkind
(Id
) = N_Defining_Operator_Symbol
2071 (In_Use
(Etype
(First_Formal
(Id
)))
2073 (Present
(Next_Formal
(First_Formal
(Id
)))
2074 and then In_Use
(Etype
(Next_Formal
2075 (First_Formal
(Id
))))))
2080 Set_Is_Potentially_Use_Visible
(Id
, False);
2083 if Is_Private_Type
(Id
)
2084 and then Present
(Full_View
(Id
))
2086 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
2092 if Present
(Renamed_Object
(Pack
)) then
2093 Set_In_Use
(Renamed_Object
(Pack
), False);
2096 if Chars
(Pack
) = Name_System
2097 and then Scope
(Pack
) = Standard_Standard
2098 and then Present_System_Aux
2100 Id
:= First_Entity
(System_Aux_Id
);
2102 while Present
(Id
) loop
2103 Set_Is_Potentially_Use_Visible
(Id
, False);
2105 if Is_Private_Type
(Id
)
2106 and then Present
(Full_View
(Id
))
2108 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
2114 Set_In_Use
(System_Aux_Id
, False);
2118 Set_Redundant_Use
(Pack_Name
, False);
2126 if Present
(Hidden_By_Use_Clause
(N
)) then
2127 Elmt
:= First_Elmt
(Hidden_By_Use_Clause
(N
));
2129 while Present
(Elmt
) loop
2130 Set_Is_Immediately_Visible
(Node
(Elmt
));
2134 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
2136 end End_Use_Package
;
2142 procedure End_Use_Type
(N
: Node_Id
) is
2149 Id
:= First
(Subtype_Marks
(N
));
2151 while Present
(Id
) loop
2154 if T
= Any_Type
then
2157 -- Note that the use_Type clause may mention a subtype of the
2158 -- type whose primitive operations have been made visible. Here
2159 -- as elsewhere, it is the base type that matters for visibility.
2161 elsif In_Open_Scopes
(Scope
(Base_Type
(T
))) then
2164 elsif not Redundant_Use
(Id
) then
2165 Set_In_Use
(T
, False);
2166 Set_In_Use
(Base_Type
(T
), False);
2167 Op_List
:= Collect_Primitive_Operations
(T
);
2168 Elmt
:= First_Elmt
(Op_List
);
2170 while Present
(Elmt
) loop
2172 if Nkind
(Node
(Elmt
)) = N_Defining_Operator_Symbol
then
2173 Set_Is_Potentially_Use_Visible
(Node
(Elmt
), False);
2184 ----------------------
2185 -- Find_Direct_Name --
2186 ----------------------
2188 procedure Find_Direct_Name
(N
: Node_Id
) is
2193 Inst
: Entity_Id
:= Empty
;
2194 -- Enclosing instance, if any.
2196 Homonyms
: Entity_Id
;
2197 -- Saves start of homonym chain
2199 Nvis_Entity
: Boolean;
2200 -- Set True to indicate that at there is at least one entity on the
2201 -- homonym chain which, while not visible, is visible enough from the
2202 -- user point of view to warrant an error message of "not visible"
2203 -- rather than undefined.
2205 function From_Actual_Package
(E
: Entity_Id
) return Boolean;
2206 -- Returns true if the entity is declared in a package that is
2207 -- an actual for a formal package of the current instance. Such an
2208 -- entity requires special handling because it may be use-visible
2209 -- but hides directly visible entities defined outside the instance.
2211 function Known_But_Invisible
(E
: Entity_Id
) return Boolean;
2212 -- This function determines whether the entity E (which is not
2213 -- visible) can reasonably be considered to be known to the writer
2214 -- of the reference. This is a heuristic test, used only for the
2215 -- purposes of figuring out whether we prefer to complain that an
2216 -- entity is undefined or invisible (and identify the declaration
2217 -- of the invisible entity in the latter case). The point here is
2218 -- that we don't want to complain that something is invisible and
2219 -- then point to something entirely mysterious to the writer.
2221 procedure Nvis_Messages
;
2222 -- Called if there are no visible entries for N, but there is at least
2223 -- one non-directly visible, or hidden declaration. This procedure
2224 -- outputs an appropriate set of error messages.
2226 procedure Undefined
(Nvis
: Boolean);
2227 -- This function is called if the current node has no corresponding
2228 -- visible entity or entities. The value set in Msg indicates whether
2229 -- an error message was generated (multiple error messages for the
2230 -- same variable are generally suppressed, see body for details).
2231 -- Msg is True if an error message was generated, False if not. This
2232 -- value is used by the caller to determine whether or not to output
2233 -- additional messages where appropriate. The parameter is set False
2234 -- to get the message "X is undefined", and True to get the message
2235 -- "X is not visible".
2237 -------------------------
2238 -- From_Actual_Package --
2239 -------------------------
2241 function From_Actual_Package
(E
: Entity_Id
) return Boolean is
2242 Scop
: constant Entity_Id
:= Scope
(E
);
2246 if not In_Instance
then
2249 Inst
:= Current_Scope
;
2251 while Present
(Inst
)
2252 and then Ekind
(Inst
) /= E_Package
2253 and then not Is_Generic_Instance
(Inst
)
2255 Inst
:= Scope
(Inst
);
2262 Act
:= First_Entity
(Inst
);
2264 while Present
(Act
) loop
2265 if Ekind
(Act
) = E_Package
then
2267 -- Check for end of actuals list
2269 if Renamed_Object
(Act
) = Inst
then
2272 elsif Present
(Associated_Formal_Package
(Act
))
2273 and then Renamed_Object
(Act
) = Scop
2275 -- Entity comes from (instance of) formal package
2290 end From_Actual_Package
;
2292 -------------------------
2293 -- Known_But_Invisible --
2294 -------------------------
2296 function Known_But_Invisible
(E
: Entity_Id
) return Boolean is
2297 Fname
: File_Name_Type
;
2300 -- Entities in Standard are always considered to be known
2302 if Sloc
(E
) <= Standard_Location
then
2305 -- An entity that does not come from source is always considered
2306 -- to be unknown, since it is an artifact of code expansion.
2308 elsif not Comes_From_Source
(E
) then
2311 -- In gnat internal mode, we consider all entities known
2313 elsif GNAT_Mode
then
2317 -- Here we have an entity that is not from package Standard, and
2318 -- which comes from Source. See if it comes from an internal file.
2320 Fname
:= Unit_File_Name
(Get_Source_Unit
(E
));
2322 -- Case of from internal file
2324 if Is_Internal_File_Name
(Fname
) then
2326 -- Private part entities in internal files are never considered
2327 -- to be known to the writer of normal application code.
2329 if Is_Hidden
(E
) then
2333 -- Entities from System packages other than System and
2334 -- System.Storage_Elements are not considered to be known.
2335 -- System.Auxxxx files are also considered known to the user.
2337 -- Should refine this at some point to generally distinguish
2338 -- between known and unknown internal files ???
2340 Get_Name_String
(Fname
);
2345 Name_Buffer
(1 .. 2) /= "s-"
2347 Name_Buffer
(3 .. 8) = "stoele"
2349 Name_Buffer
(3 .. 5) = "aux";
2351 -- If not an internal file, then entity is definitely known,
2352 -- even if it is in a private part (the message generated will
2353 -- note that it is in a private part)
2358 end Known_But_Invisible
;
2364 procedure Nvis_Messages
is
2366 Hidden
: Boolean := False;
2369 Undefined
(Nvis
=> True);
2373 -- First loop does hidden declarations
2376 while Present
(Ent
) loop
2377 if Is_Potentially_Use_Visible
(Ent
) then
2380 Error_Msg_N
("multiple use clauses cause hiding!", N
);
2384 Error_Msg_Sloc
:= Sloc
(Ent
);
2385 Error_Msg_N
("hidden declaration#!", N
);
2388 Ent
:= Homonym
(Ent
);
2391 -- If we found hidden declarations, then that's enough, don't
2392 -- bother looking for non-visible declarations as well.
2398 -- Second loop does non-directly visible declarations
2401 while Present
(Ent
) loop
2402 if not Is_Potentially_Use_Visible
(Ent
) then
2404 -- Do not bother the user with unknown entities
2406 if not Known_But_Invisible
(Ent
) then
2410 Error_Msg_Sloc
:= Sloc
(Ent
);
2412 -- Output message noting that there is a non-visible
2413 -- declaration, distinguishing the private part case.
2415 if Is_Hidden
(Ent
) then
2416 Error_Msg_N
("non-visible (private) declaration#!", N
);
2418 Error_Msg_N
("non-visible declaration#!", N
);
2421 -- Set entity and its containing package as referenced. We
2422 -- can't be sure of this, but this seems a better choice
2423 -- to avoid unused entity messages.
2425 if Comes_From_Source
(Ent
) then
2426 Set_Referenced
(Ent
);
2427 Set_Referenced
(Cunit_Entity
(Get_Source_Unit
(Ent
)));
2432 Ent
:= Homonym
(Ent
);
2442 procedure Undefined
(Nvis
: Boolean) is
2443 Emsg
: Error_Msg_Id
;
2446 -- A very specialized error check, if the undefined variable is
2447 -- a case tag, and the case type is an enumeration type, check
2448 -- for a possible misspelling, and if so, modify the identifier
2450 -- Named aggregate should also be handled similarly ???
2452 if Nkind
(N
) = N_Identifier
2453 and then Nkind
(Parent
(N
)) = N_Case_Statement_Alternative
2455 Get_Name_String
(Chars
(N
));
2458 Case_Str
: constant String := Name_Buffer
(1 .. Name_Len
);
2459 Case_Stm
: constant Node_Id
:= Parent
(Parent
(N
));
2460 Case_Typ
: constant Entity_Id
:= Etype
(Expression
(Case_Stm
));
2465 if Is_Enumeration_Type
(Case_Typ
)
2466 and then Case_Typ
/= Standard_Character
2467 and then Case_Typ
/= Standard_Wide_Character
2469 Lit
:= First_Literal
(Case_Typ
);
2470 Get_Name_String
(Chars
(Lit
));
2472 if Chars
(Lit
) /= Chars
(N
)
2473 and then Is_Bad_Spelling_Of
2474 (Case_Str
, Name_Buffer
(1 .. Name_Len
))
2476 Error_Msg_Node_2
:= Lit
;
2478 ("& is undefined, assume misspelling of &", N
);
2479 Rewrite
(N
, New_Occurrence_Of
(Lit
, Sloc
(N
)));
2483 Lit
:= Next_Literal
(Lit
);
2488 -- Normal processing
2490 Set_Entity
(N
, Any_Id
);
2491 Set_Etype
(N
, Any_Type
);
2493 -- We use the table Urefs to keep track of entities for which we
2494 -- have issued errors for undefined references. Multiple errors
2495 -- for a single name are normally suppressed, however we modify
2496 -- the error message to alert the programmer to this effect.
2498 for J
in Urefs
.First
.. Urefs
.Last
loop
2499 if Chars
(N
) = Chars
(Urefs
.Table
(J
).Node
) then
2500 if Urefs
.Table
(J
).Err
/= No_Error_Msg
2501 and then Sloc
(N
) /= Urefs
.Table
(J
).Loc
2503 Error_Msg_Node_1
:= Urefs
.Table
(J
).Node
;
2505 if Urefs
.Table
(J
).Nvis
then
2506 Change_Error_Text
(Urefs
.Table
(J
).Err
,
2507 "& is not visible (more references follow)");
2509 Change_Error_Text
(Urefs
.Table
(J
).Err
,
2510 "& is undefined (more references follow)");
2513 Urefs
.Table
(J
).Err
:= No_Error_Msg
;
2516 -- Although we will set Msg False, and thus suppress the
2517 -- message, we also set Error_Posted True, to avoid any
2518 -- cascaded messages resulting from the undefined reference.
2521 Set_Error_Posted
(N
, True);
2526 -- If entry not found, this is first undefined occurrence
2529 Error_Msg_N
("& is not visible!", N
);
2533 Error_Msg_N
("& is undefined!", N
);
2536 -- A very bizarre special check, if the undefined identifier
2537 -- is put or put_line, then add a special error message (since
2538 -- this is a very common error for beginners to make).
2540 if Chars
(N
) = Name_Put
or else Chars
(N
) = Name_Put_Line
then
2541 Error_Msg_N
("\possible missing with of 'Text_'I'O!", N
);
2544 -- Now check for possible misspellings
2546 Get_Name_String
(Chars
(N
));
2550 Ematch
: Entity_Id
:= Empty
;
2552 Last_Name_Id
: constant Name_Id
:=
2553 Name_Id
(Nat
(First_Name_Id
) +
2554 Name_Entries_Count
- 1);
2556 S
: constant String (1 .. Name_Len
) :=
2557 Name_Buffer
(1 .. Name_Len
);
2560 for N
in First_Name_Id
.. Last_Name_Id
loop
2561 E
:= Get_Name_Entity_Id
(N
);
2564 and then (Is_Immediately_Visible
(E
)
2566 Is_Potentially_Use_Visible
(E
))
2568 Get_Name_String
(N
);
2570 if Is_Bad_Spelling_Of
2571 (Name_Buffer
(1 .. Name_Len
), S
)
2579 if Present
(Ematch
) then
2580 Error_Msg_NE
("\possible misspelling of&", N
, Ematch
);
2585 -- Make entry in undefined references table unless the full
2586 -- errors switch is set, in which case by refraining from
2587 -- generating the table entry, we guarantee that we get an
2588 -- error message for every undefined reference.
2590 if not All_Errors_Mode
then
2591 Urefs
.Increment_Last
;
2592 Urefs
.Table
(Urefs
.Last
).Node
:= N
;
2593 Urefs
.Table
(Urefs
.Last
).Err
:= Emsg
;
2594 Urefs
.Table
(Urefs
.Last
).Nvis
:= Nvis
;
2595 Urefs
.Table
(Urefs
.Last
).Loc
:= Sloc
(N
);
2601 -- Start of processing for Find_Direct_Name
2604 -- If the entity pointer is already set, this is an internal node, or
2605 -- a node that is analyzed more than once, after a tree modification.
2606 -- In such a case there is no resolution to perform, just set the type.
2608 if Present
(Entity
(N
)) then
2609 if Is_Type
(Entity
(N
)) then
2610 Set_Etype
(N
, Entity
(N
));
2614 Entyp
: constant Entity_Id
:= Etype
(Entity
(N
));
2617 -- One special case here. If the Etype field is already set,
2618 -- and references the packed array type corresponding to the
2619 -- etype of the referenced entity, then leave it alone. This
2620 -- happens for trees generated from Exp_Pakd, where expressions
2621 -- can be deliberately "mis-typed" to the packed array type.
2623 if Is_Array_Type
(Entyp
)
2624 and then Is_Packed
(Entyp
)
2625 and then Present
(Etype
(N
))
2626 and then Etype
(N
) = Packed_Array_Type
(Entyp
)
2630 -- If not that special case, then just reset the Etype
2633 Set_Etype
(N
, Etype
(Entity
(N
)));
2641 -- Here if Entity pointer was not set, we need full visibility analysis
2642 -- First we generate debugging output if the debug E flag is set.
2644 if Debug_Flag_E
then
2645 Write_Str
("Looking for ");
2646 Write_Name
(Chars
(N
));
2650 Homonyms
:= Current_Entity
(N
);
2651 Nvis_Entity
:= False;
2654 while Present
(E
) loop
2656 -- If entity is immediately visible or potentially use
2657 -- visible, then process the entity and we are done.
2659 if Is_Immediately_Visible
(E
) then
2660 goto Immediately_Visible_Entity
;
2662 elsif Is_Potentially_Use_Visible
(E
) then
2663 goto Potentially_Use_Visible_Entity
;
2665 -- Note if a known but invisible entity encountered
2667 elsif Known_But_Invisible
(E
) then
2668 Nvis_Entity
:= True;
2671 -- Move to next entity in chain and continue search
2676 -- If no entries on homonym chain that were potentially visible,
2677 -- and no entities reasonably considered as non-visible, then
2678 -- we have a plain undefined reference, with no additional
2679 -- explanation required!
2681 if not Nvis_Entity
then
2682 Undefined
(Nvis
=> False);
2685 -- Otherwise there is at least one entry on the homonym chain that
2686 -- is reasonably considered as being known and non-visible.
2693 -- Processing for a potentially use visible entry found. We must search
2694 -- the rest of the homonym chain for two reasons. First, if there is a
2695 -- directly visible entry, then none of the potentially use-visible
2696 -- entities are directly visible (RM 8.4(10)). Second, we need to check
2697 -- for the case of multiple potentially use-visible entries hiding one
2698 -- another and as a result being non-directly visible (RM 8.4(11)).
2700 <<Potentially_Use_Visible_Entity
>> declare
2701 Only_One_Visible
: Boolean := True;
2702 All_Overloadable
: Boolean := Is_Overloadable
(E
);
2707 while Present
(E2
) loop
2708 if Is_Immediately_Visible
(E2
) then
2710 -- If the use-visible entity comes from the actual for a
2711 -- formal package, it hides a directly visible entity from
2712 -- outside the instance.
2714 if From_Actual_Package
(E
)
2715 and then Scope_Depth
(E2
) < Scope_Depth
(Inst
)
2720 goto Immediately_Visible_Entity
;
2723 elsif Is_Potentially_Use_Visible
(E2
) then
2724 Only_One_Visible
:= False;
2725 All_Overloadable
:= All_Overloadable
and Is_Overloadable
(E2
);
2731 -- On falling through this loop, we have checked that there are no
2732 -- immediately visible entities. Only_One_Visible is set if exactly
2733 -- one potentially use visible entity exists. All_Overloadable is
2734 -- set if all the potentially use visible entities are overloadable.
2735 -- The condition for legality is that either there is one potentially
2736 -- use visible entity, or if there is more than one, then all of them
2737 -- are overloadable.
2739 if Only_One_Visible
or All_Overloadable
then
2742 -- If there is more than one potentially use-visible entity and at
2743 -- least one of them non-overloadable, we have an error (RM 8.4(11).
2744 -- Note that E points to the first such entity on the homonym list.
2745 -- Special case: if one of the entities is declared in an actual
2746 -- package, it was visible in the generic, and takes precedence over
2747 -- other entities that are potentially use-visible.
2753 while Present
(E2
) loop
2754 if Is_Generic_Instance
(Scope
(E2
)) then
2772 -- Come here with E set to the first immediately visible entity on
2773 -- the homonym chain. This is the one we want unless there is another
2774 -- immediately visible entity further on in the chain for a more
2775 -- inner scope (RM 8.3(8)).
2777 <<Immediately_Visible_Entity
>> declare
2782 -- Find scope level of initial entity. When compiling through
2783 -- Rtsfind, the previous context is not completely invisible, and
2784 -- an outer entity may appear on the chain, whose scope is below
2785 -- the entry for Standard that delimits the current scope stack.
2786 -- Indicate that the level for this spurious entry is outside of
2787 -- the current scope stack.
2789 Level
:= Scope_Stack
.Last
;
2791 Scop
:= Scope_Stack
.Table
(Level
).Entity
;
2792 exit when Scop
= Scope
(E
);
2794 exit when Scop
= Standard_Standard
;
2797 -- Now search remainder of homonym chain for more inner entry
2798 -- If the entity is Standard itself, it has no scope, and we
2799 -- compare it with the stack entry directly.
2802 while Present
(E2
) loop
2803 if Is_Immediately_Visible
(E2
) then
2804 for J
in Level
+ 1 .. Scope_Stack
.Last
loop
2805 if Scope_Stack
.Table
(J
).Entity
= Scope
(E2
)
2806 or else Scope_Stack
.Table
(J
).Entity
= E2
2818 -- At the end of that loop, E is the innermost immediately
2819 -- visible entity, so we are all set.
2822 -- Come here with entity found, and stored in E
2826 if Comes_From_Source
(N
)
2827 and then Is_Remote_Access_To_Subprogram_Type
(E
)
2828 and then Expander_Active
2831 New_Occurrence_Of
(Equivalent_Type
(E
), Sloc
(N
)));
2836 -- Why no Style_Check here???
2841 Set_Etype
(N
, Get_Full_View
(Etype
(E
)));
2844 if Debug_Flag_E
then
2845 Write_Str
(" found ");
2846 Write_Entity_Info
(E
, " ");
2849 -- If the Ekind of the entity is Void, it means that all homonyms
2850 -- are hidden from all visibility (RM 8.3(5,14-20)). However, this
2851 -- test is skipped if the current scope is a record and the name is
2852 -- a pragma argument expression (case of Atomic and Volatile pragmas
2853 -- and possibly other similar pragmas added later, which are allowed
2854 -- to reference components in the current record).
2856 if Ekind
(E
) = E_Void
2858 (not Is_Record_Type
(Current_Scope
)
2859 or else Nkind
(Parent
(N
)) /= N_Pragma_Argument_Association
)
2861 Premature_Usage
(N
);
2863 -- If the entity is overloadable, collect all interpretations
2864 -- of the name for subsequent overload resolution. We optimize
2865 -- a bit here to do this only if we have an overloadable entity
2866 -- that is not on its own on the homonym chain.
2868 elsif Is_Overloadable
(E
)
2869 and then (Present
(Homonym
(E
)) or else Current_Entity
(N
) /= E
)
2871 Collect_Interps
(N
);
2873 -- If no homonyms were visible, the entity is unambiguous.
2875 if not Is_Overloaded
(N
) then
2876 Generate_Reference
(E
, N
);
2879 -- Case of non-overloadable entity, set the entity providing that
2880 -- we do not have the case of a discriminant reference within a
2881 -- default expression. Such references are replaced with the
2882 -- corresponding discriminal, which is the formal corresponding to
2883 -- to the discriminant in the initialization procedure.
2885 -- This replacement must not be done if we are currently processing
2886 -- a generic spec or body.
2888 -- The replacement is not done either for a task discriminant that
2889 -- appears in a default expression of an entry parameter. See
2890 -- Expand_Discriminant in exp_ch2 for details on their handling.
2893 -- Entity is unambiguous, indicate that it is referenced here
2894 -- One slightly odd case is that we do not want to set the
2895 -- Referenced flag if the entity is a label, and the identifier
2896 -- is the label in the source, since this is not a reference
2897 -- from the point of view of the user
2899 if Nkind
(Parent
(N
)) = N_Label
then
2901 R
: constant Boolean := Referenced
(E
);
2904 Generate_Reference
(E
, N
);
2905 Set_Referenced
(E
, R
);
2909 Generate_Reference
(E
, N
);
2912 if not In_Default_Expression
2913 or else Ekind
(E
) /= E_Discriminant
2914 or else Inside_A_Generic
2916 Set_Entity_With_Style_Check
(N
, E
);
2918 elsif Is_Concurrent_Type
(Scope
(E
)) then
2920 P
: Node_Id
:= Parent
(N
);
2924 and then Nkind
(P
) /= N_Parameter_Specification
2925 and then Nkind
(P
) /= N_Component_Declaration
2931 and then Nkind
(P
) = N_Parameter_Specification
2935 Set_Entity
(N
, Discriminal
(E
));
2940 Set_Entity
(N
, Discriminal
(E
));
2944 end Find_Direct_Name
;
2946 ------------------------
2947 -- Find_Expanded_Name --
2948 ------------------------
2950 -- This routine searches the homonym chain of the entity until it finds
2951 -- an entity declared in the scope denoted by the prefix. If the entity
2952 -- is private, it may nevertheless be immediately visible, if we are in
2953 -- the scope of its declaration.
2955 procedure Find_Expanded_Name
(N
: Node_Id
) is
2956 Selector
: constant Node_Id
:= Selector_Name
(N
);
2957 Candidate
: Entity_Id
:= Empty
;
2963 P_Name
:= Entity
(Prefix
(N
));
2966 -- If the prefix is a renamed package, look for the entity
2967 -- in the original package.
2969 if Ekind
(P_Name
) = E_Package
2970 and then Present
(Renamed_Object
(P_Name
))
2972 P_Name
:= Renamed_Object
(P_Name
);
2974 -- Rewrite node with entity field pointing to renamed object
2976 Rewrite
(Prefix
(N
), New_Copy
(Prefix
(N
)));
2977 Set_Entity
(Prefix
(N
), P_Name
);
2979 -- If the prefix is an object of a concurrent type, look for
2980 -- the entity in the associated task or protected type.
2982 elsif Is_Concurrent_Type
(Etype
(P_Name
)) then
2983 P_Name
:= Etype
(P_Name
);
2986 Id
:= Current_Entity
(Selector
);
2988 while Present
(Id
) loop
2990 if Scope
(Id
) = P_Name
then
2993 if Is_Child_Unit
(Id
) then
2995 (Is_Visible_Child_Unit
(Id
)
2996 or else Is_Immediately_Visible
(Id
));
3000 (not Is_Hidden
(Id
) or else Is_Immediately_Visible
(Id
));
3008 and then (Ekind
(P_Name
) = E_Procedure
3010 Ekind
(P_Name
) = E_Function
)
3011 and then Is_Generic_Instance
(P_Name
)
3013 -- Expanded name denotes entity in (instance of) generic subprogram.
3014 -- The entity may be in the subprogram instance, or may denote one of
3015 -- the formals, which is declared in the enclosing wrapper package.
3017 P_Name
:= Scope
(P_Name
);
3018 Id
:= Current_Entity
(Selector
);
3020 while Present
(Id
) loop
3021 exit when Scope
(Id
) = P_Name
;
3026 if No
(Id
) or else Chars
(Id
) /= Chars
(Selector
) then
3028 Set_Etype
(N
, Any_Type
);
3030 -- If we are looking for an entity defined in System, try to
3031 -- find it in the child package that may have been provided as
3032 -- an extension to System. The Extend_System pragma will have
3033 -- supplied the name of the extension, which may have to be loaded.
3035 if Chars
(P_Name
) = Name_System
3036 and then Scope
(P_Name
) = Standard_Standard
3037 and then Present
(System_Extend_Pragma_Arg
)
3038 and then Present_System_Aux
(N
)
3040 Set_Entity
(Prefix
(N
), System_Aux_Id
);
3041 Find_Expanded_Name
(N
);
3044 elsif (Nkind
(Selector
) = N_Operator_Symbol
3045 and then Has_Implicit_Operator
(N
))
3047 -- There is an implicit instance of the predefined operator in
3048 -- the given scope. The operator entity is defined in Standard.
3049 -- Has_Implicit_Operator makes the node into an Expanded_Name.
3053 elsif Nkind
(Selector
) = N_Character_Literal
3054 and then Has_Implicit_Character_Literal
(N
)
3056 -- If there is no literal defined in the scope denoted by the
3057 -- prefix, the literal may belong to (a type derived from)
3058 -- Standard_Character, for which we have no explicit literals.
3063 -- If the prefix is a single concurrent object, use its
3064 -- name in the error message, rather than that of the
3067 if Is_Concurrent_Type
(P_Name
)
3068 and then Is_Internal_Name
(Chars
(P_Name
))
3070 Error_Msg_Node_2
:= Entity
(Prefix
(N
));
3072 Error_Msg_Node_2
:= P_Name
;
3075 if P_Name
= System_Aux_Id
then
3076 P_Name
:= Scope
(P_Name
);
3077 Set_Entity
(Prefix
(N
), P_Name
);
3080 if Present
(Candidate
) then
3082 if Is_Child_Unit
(Candidate
) then
3084 ("missing with_clause for child unit &", Selector
);
3086 Error_Msg_NE
("& is not a visible entity of&", N
, Selector
);
3090 -- Within the instantiation of a child unit, the prefix may
3091 -- denote the parent instance, but the selector has the
3092 -- name of the original child. Find whether we are within
3093 -- the corresponding instance, and get the proper entity, which
3094 -- can only be an enclosing scope.
3097 and then In_Open_Scopes
(P_Name
)
3098 and then Is_Generic_Instance
(P_Name
)
3101 S
: Entity_Id
:= Current_Scope
;
3105 for J
in reverse 0 .. Scope_Stack
.Last
loop
3106 S
:= Scope_Stack
.Table
(J
).Entity
;
3108 exit when S
= Standard_Standard
;
3110 if Ekind
(S
) = E_Function
3111 or else Ekind
(S
) = E_Package
3112 or else Ekind
(S
) = E_Procedure
3114 P
:= Generic_Parent
(Specification
3115 (Unit_Declaration_Node
(S
)));
3118 and then Chars
(Scope
(P
)) = Chars
(O_Name
)
3119 and then Chars
(P
) = Chars
(Selector
)
3130 if (Chars
(P_Name
) = Name_Ada
3131 and then Scope
(P_Name
) = Standard_Standard
)
3133 Error_Msg_Node_2
:= Selector
;
3135 ("\missing with for `&.&`", N
, P_Name
);
3137 -- If this is a selection from a dummy package, then
3138 -- suppress the error message, of course the entity
3139 -- is missing if the package is missing!
3141 elsif Sloc
(Error_Msg_Node_2
) = No_Location
then
3144 -- Here we have the case of an undefined component
3148 Error_Msg_NE
("& not declared in&", N
, Selector
);
3150 -- Check for misspelling of some entity in prefix.
3152 Id
:= First_Entity
(P_Name
);
3153 Get_Name_String
(Chars
(Selector
));
3156 S
: constant String (1 .. Name_Len
) :=
3157 Name_Buffer
(1 .. Name_Len
);
3159 while Present
(Id
) loop
3160 Get_Name_String
(Chars
(Id
));
3161 if Is_Bad_Spelling_Of
3162 (Name_Buffer
(1 .. Name_Len
), S
)
3163 and then not Is_Internal_Name
(Chars
(Id
))
3166 ("possible misspelling of&", Selector
, Id
);
3174 -- Specialize the message if this may be an instantiation
3175 -- of a child unit that was not mentioned in the context.
3177 if Nkind
(Parent
(N
)) = N_Package_Instantiation
3178 and then Is_Generic_Instance
(Entity
(Prefix
(N
)))
3179 and then Is_Compilation_Unit
3180 (Generic_Parent
(Parent
(Entity
(Prefix
(N
)))))
3183 ("\possible missing with clause on child unit&",
3194 if Comes_From_Source
(N
)
3195 and then Is_Remote_Access_To_Subprogram_Type
(Id
)
3197 Id
:= Equivalent_Type
(Id
);
3198 Set_Chars
(Selector
, Chars
(Id
));
3201 if Ekind
(P_Name
) = E_Package
3202 and then From_With_Type
(P_Name
)
3204 if From_With_Type
(Id
)
3205 or else (Ekind
(Id
) = E_Package
and then From_With_Type
(Id
))
3210 ("imported package can only be used to access imported type",
3215 if Is_Task_Type
(P_Name
)
3216 and then ((Ekind
(Id
) = E_Entry
3217 and then Nkind
(Parent
(N
)) /= N_Attribute_Reference
)
3219 (Ekind
(Id
) = E_Entry_Family
3221 Nkind
(Parent
(Parent
(N
))) /= N_Attribute_Reference
))
3223 -- It is an entry call after all, either to the current task
3224 -- (which will deadlock) or to an enclosing task.
3226 Analyze_Selected_Component
(N
);
3230 Change_Selected_Component_To_Expanded_Name
(N
);
3232 -- Do style check and generate reference, but skip both steps if this
3233 -- entity has homonyms, since we may not have the right homonym set
3234 -- yet. The proper homonym will be set during the resolve phase.
3236 if Has_Homonym
(Id
) then
3239 Set_Entity_With_Style_Check
(N
, Id
);
3240 Generate_Reference
(Id
, N
);
3243 if Is_Type
(Id
) then
3246 Set_Etype
(N
, Get_Full_View
(Etype
(Id
)));
3249 -- If the Ekind of the entity is Void, it means that all homonyms
3250 -- are hidden from all visibility (RM 8.3(5,14-20)).
3252 if Ekind
(Id
) = E_Void
then
3253 Premature_Usage
(N
);
3255 elsif Is_Overloadable
(Id
)
3256 and then Present
(Homonym
(Id
))
3259 H
: Entity_Id
:= Homonym
(Id
);
3262 while Present
(H
) loop
3263 if Scope
(H
) = Scope
(Id
) then
3264 Collect_Interps
(N
);
3273 if Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
3274 and then Scope
(Id
) /= Standard_Standard
3276 -- In addition to user-defined operators in the given scope,
3277 -- there may be an implicit instance of the predefined
3278 -- operator. The operator (defined in Standard) is found
3279 -- in Has_Implicit_Operator, and added to the interpretations.
3280 -- Procedure Add_One_Interp will determine which hides which.
3282 if Has_Implicit_Operator
(N
) then
3286 end Find_Expanded_Name
;
3288 -------------------------
3289 -- Find_Renamed_Entity --
3290 -------------------------
3292 function Find_Renamed_Entity
3296 Is_Actual
: Boolean := False) return Entity_Id
3299 I1
: Interp_Index
:= 0; -- Suppress junk warnings
3305 function Enclosing_Instance
return Entity_Id
;
3306 -- If the renaming determines the entity for the default of a formal
3307 -- subprogram nested within another instance, choose the innermost
3308 -- candidate. This is because if the formal has a box, and we are within
3309 -- an enclosing instance where some candidate interpretations are local
3310 -- to this enclosing instance, we know that the default was properly
3311 -- resolved when analyzing the generic, so we prefer the local
3312 -- candidates to those that are external. This is not always the case
3313 -- but is a reasonable heuristic on the use of nested generics.
3314 -- The proper solution requires a full renaming model.
3316 function Within
(Inner
, Outer
: Entity_Id
) return Boolean;
3317 -- Determine whether a candidate subprogram is defined within
3318 -- the enclosing instance. If yes, it has precedence over outer
3321 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean;
3322 -- If the renamed entity is an implicit operator, check whether it is
3323 -- visible because its operand type is properly visible. This
3324 -- check applies to explicit renamed entities that appear in the
3325 -- source in a renaming declaration or a formal subprogram instance,
3326 -- but not to default generic actuals with a name.
3328 ------------------------
3329 -- Enclosing_Instance --
3330 ------------------------
3332 function Enclosing_Instance
return Entity_Id
is
3336 if not Is_Generic_Instance
(Current_Scope
)
3337 and then not Is_Actual
3342 S
:= Scope
(Current_Scope
);
3344 while S
/= Standard_Standard
loop
3346 if Is_Generic_Instance
(S
) then
3354 end Enclosing_Instance
;
3356 --------------------------
3357 -- Is_Visible_Operation --
3358 --------------------------
3360 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean is
3366 if Ekind
(Op
) /= E_Operator
3367 or else Scope
(Op
) /= Standard_Standard
3368 or else (In_Instance
3371 or else Present
(Enclosing_Instance
)))
3376 -- For a fixed point type operator, check the resulting type,
3377 -- because it may be a mixed mode integer * fixed operation.
3379 if Present
(Next_Formal
(First_Formal
(New_S
)))
3380 and then Is_Fixed_Point_Type
(Etype
(New_S
))
3382 Typ
:= Etype
(New_S
);
3384 Typ
:= Etype
(First_Formal
(New_S
));
3387 Btyp
:= Base_Type
(Typ
);
3389 if Nkind
(Nam
) /= N_Expanded_Name
then
3390 return (In_Open_Scopes
(Scope
(Btyp
))
3391 or else Is_Potentially_Use_Visible
(Btyp
)
3392 or else In_Use
(Btyp
)
3393 or else In_Use
(Scope
(Btyp
)));
3396 Scop
:= Entity
(Prefix
(Nam
));
3398 if Ekind
(Scop
) = E_Package
3399 and then Present
(Renamed_Object
(Scop
))
3401 Scop
:= Renamed_Object
(Scop
);
3404 -- Operator is visible if prefix of expanded name denotes
3405 -- scope of type, or else type type is defined in System_Aux
3406 -- and the prefix denotes System.
3408 return Scope
(Btyp
) = Scop
3409 or else (Scope
(Btyp
) = System_Aux_Id
3410 and then Scope
(Scope
(Btyp
)) = Scop
);
3413 end Is_Visible_Operation
;
3419 function Within
(Inner
, Outer
: Entity_Id
) return Boolean is
3420 Sc
: Entity_Id
:= Scope
(Inner
);
3423 while Sc
/= Standard_Standard
loop
3435 -- Start of processing for Find_Renamed_Entry
3439 Candidate_Renaming
:= Empty
;
3441 if not Is_Overloaded
(Nam
) then
3442 if Entity_Matches_Spec
(Entity
(Nam
), New_S
)
3443 and then Is_Visible_Operation
(Entity
(Nam
))
3445 Old_S
:= Entity
(Nam
);
3448 Present
(First_Formal
(Entity
(Nam
)))
3449 and then Present
(First_Formal
(New_S
))
3450 and then (Base_Type
(Etype
(First_Formal
(Entity
(Nam
))))
3451 = Base_Type
(Etype
(First_Formal
(New_S
))))
3453 Candidate_Renaming
:= Entity
(Nam
);
3457 Get_First_Interp
(Nam
, I
, It
);
3459 while Present
(It
.Nam
) loop
3461 if Entity_Matches_Spec
(It
.Nam
, New_S
)
3462 and then Is_Visible_Operation
(It
.Nam
)
3464 if Old_S
/= Any_Id
then
3466 -- Note: The call to Disambiguate only happens if a
3467 -- previous interpretation was found, in which case I1
3468 -- has received a value.
3470 It1
:= Disambiguate
(Nam
, I1
, I
, Etype
(Old_S
));
3472 if It1
= No_Interp
then
3474 Inst
:= Enclosing_Instance
;
3476 if Present
(Inst
) then
3478 if Within
(It
.Nam
, Inst
) then
3481 elsif Within
(Old_S
, Inst
) then
3485 Error_Msg_N
("ambiguous renaming", N
);
3490 Error_Msg_N
("ambiguous renaming", N
);
3505 Present
(First_Formal
(It
.Nam
))
3506 and then Present
(First_Formal
(New_S
))
3507 and then (Base_Type
(Etype
(First_Formal
(It
.Nam
)))
3508 = Base_Type
(Etype
(First_Formal
(New_S
))))
3510 Candidate_Renaming
:= It
.Nam
;
3513 Get_Next_Interp
(I
, It
);
3516 Set_Entity
(Nam
, Old_S
);
3517 Set_Is_Overloaded
(Nam
, False);
3521 end Find_Renamed_Entity
;
3523 -----------------------------
3524 -- Find_Selected_Component --
3525 -----------------------------
3527 procedure Find_Selected_Component
(N
: Node_Id
) is
3528 P
: Node_Id
:= Prefix
(N
);
3531 -- Entity denoted by prefix
3541 if Nkind
(P
) = N_Error
then
3544 -- If the selector already has an entity, the node has been
3545 -- constructed in the course of expansion, and is known to be
3546 -- valid. Do not verify that it is defined for the type (it may
3547 -- be a private component used in the expansion of record equality).
3549 elsif Present
(Entity
(Selector_Name
(N
))) then
3552 or else Etype
(N
) = Any_Type
3555 Sel_Name
: Node_Id
:= Selector_Name
(N
);
3556 Selector
: Entity_Id
:= Entity
(Sel_Name
);
3560 Set_Etype
(Sel_Name
, Etype
(Selector
));
3562 if not Is_Entity_Name
(P
) then
3563 Resolve
(P
, Etype
(P
));
3566 -- Build an actual subtype except for the first parameter
3567 -- of an init_proc, where this actual subtype is by
3568 -- definition incorrect, since the object is uninitialized
3569 -- (and does not even have defined discriminants etc.)
3571 if Is_Entity_Name
(P
)
3572 and then Ekind
(Entity
(P
)) = E_Function
3574 Nam
:= New_Copy
(P
);
3576 if Is_Overloaded
(P
) then
3577 Save_Interps
(P
, Nam
);
3581 Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
3583 Analyze_Selected_Component
(N
);
3586 elsif Ekind
(Selector
) = E_Component
3587 and then (not Is_Entity_Name
(P
)
3588 or else Chars
(Entity
(P
)) /= Name_uInit
)
3591 Build_Actual_Subtype_Of_Component
(
3592 Etype
(Selector
), N
);
3597 if No
(C_Etype
) then
3598 C_Etype
:= Etype
(Selector
);
3600 Insert_Action
(N
, C_Etype
);
3601 C_Etype
:= Defining_Identifier
(C_Etype
);
3604 Set_Etype
(N
, C_Etype
);
3607 -- If this is the name of an entry or protected operation, and
3608 -- the prefix is an access type, insert an explicit dereference,
3609 -- so that entry calls are treated uniformly.
3611 if Is_Access_Type
(Etype
(P
))
3612 and then Is_Concurrent_Type
(Designated_Type
(Etype
(P
)))
3616 Make_Explicit_Dereference
(Sloc
(P
),
3617 Prefix
=> Relocate_Node
(P
));
3620 Set_Etype
(P
, Designated_Type
(Etype
(Prefix
(P
))));
3624 -- If the selected component appears within a default expression
3625 -- and it has an actual subtype, the pre-analysis has not yet
3626 -- completed its analysis, because Insert_Actions is disabled in
3627 -- that context. Within the init_proc of the enclosing type we
3628 -- must complete this analysis, if an actual subtype was created.
3630 elsif Inside_Init_Proc
then
3632 Typ
: constant Entity_Id
:= Etype
(N
);
3633 Decl
: constant Node_Id
:= Declaration_Node
(Typ
);
3636 if Nkind
(Decl
) = N_Subtype_Declaration
3637 and then not Analyzed
(Decl
)
3638 and then Is_List_Member
(Decl
)
3639 and then No
(Parent
(Decl
))
3642 Insert_Action
(N
, Decl
);
3649 elsif Is_Entity_Name
(P
) then
3650 P_Name
:= Entity
(P
);
3652 -- The prefix may denote an enclosing type which is the completion
3653 -- of an incomplete type declaration.
3655 if Is_Type
(P_Name
) then
3656 Set_Entity
(P
, Get_Full_View
(P_Name
));
3657 Set_Etype
(P
, Entity
(P
));
3658 P_Name
:= Entity
(P
);
3661 P_Type
:= Base_Type
(Etype
(P
));
3663 if Debug_Flag_E
then
3664 Write_Str
("Found prefix type to be ");
3665 Write_Entity_Info
(P_Type
, " "); Write_Eol
;
3668 -- First check for components of a record object (not the
3669 -- result of a call, which is handled below).
3671 if Is_Appropriate_For_Record
(P_Type
)
3672 and then not Is_Overloadable
(P_Name
)
3673 and then not Is_Type
(P_Name
)
3675 -- Selected component of record. Type checking will validate
3676 -- name of selector.
3678 Analyze_Selected_Component
(N
);
3680 elsif Is_Appropriate_For_Entry_Prefix
(P_Type
)
3681 and then not In_Open_Scopes
(P_Name
)
3682 and then (not Is_Concurrent_Type
(Etype
(P_Name
))
3683 or else not In_Open_Scopes
(Etype
(P_Name
)))
3685 -- Call to protected operation or entry. Type checking is
3686 -- needed on the prefix.
3688 Analyze_Selected_Component
(N
);
3690 elsif (In_Open_Scopes
(P_Name
)
3691 and then Ekind
(P_Name
) /= E_Void
3692 and then not Is_Overloadable
(P_Name
))
3693 or else (Is_Concurrent_Type
(Etype
(P_Name
))
3694 and then In_Open_Scopes
(Etype
(P_Name
)))
3696 -- Prefix denotes an enclosing loop, block, or task, i.e. an
3697 -- enclosing construct that is not a subprogram or accept.
3699 Find_Expanded_Name
(N
);
3701 elsif Ekind
(P_Name
) = E_Package
then
3702 Find_Expanded_Name
(N
);
3704 elsif Is_Overloadable
(P_Name
) then
3706 -- The subprogram may be a renaming (of an enclosing scope) as
3707 -- in the case of the name of the generic within an instantiation.
3709 if (Ekind
(P_Name
) = E_Procedure
3710 or else Ekind
(P_Name
) = E_Function
)
3711 and then Present
(Alias
(P_Name
))
3712 and then Is_Generic_Instance
(Alias
(P_Name
))
3714 P_Name
:= Alias
(P_Name
);
3717 if Is_Overloaded
(P
) then
3719 -- The prefix must resolve to a unique enclosing construct.
3722 Found
: Boolean := False;
3727 Get_First_Interp
(P
, I
, It
);
3729 while Present
(It
.Nam
) loop
3731 if In_Open_Scopes
(It
.Nam
) then
3734 "prefix must be unique enclosing scope", N
);
3735 Set_Entity
(N
, Any_Id
);
3736 Set_Etype
(N
, Any_Type
);
3745 Get_Next_Interp
(I
, It
);
3750 if In_Open_Scopes
(P_Name
) then
3751 Set_Entity
(P
, P_Name
);
3752 Set_Is_Overloaded
(P
, False);
3753 Find_Expanded_Name
(N
);
3756 -- If no interpretation as an expanded name is possible, it
3757 -- must be a selected component of a record returned by a
3758 -- function call. Reformat prefix as a function call, the
3759 -- rest is done by type resolution. If the prefix is a
3760 -- procedure or entry, as is P.X; this is an error.
3762 if Ekind
(P_Name
) /= E_Function
3763 and then (not Is_Overloaded
(P
)
3765 Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
)
3768 -- Prefix may mention a package that is hidden by a local
3769 -- declaration: let the user know. Scan the full homonym
3770 -- chain, the candidate package may be anywhere on it.
3772 if Present
(Homonym
(Current_Entity
(P_Name
))) then
3774 P_Name
:= Current_Entity
(P_Name
);
3776 while Present
(P_Name
) loop
3777 exit when Ekind
(P_Name
) = E_Package
;
3778 P_Name
:= Homonym
(P_Name
);
3781 if Present
(P_Name
) then
3782 Error_Msg_Sloc
:= Sloc
(Entity
(Prefix
(N
)));
3785 ("package& is hidden by declaration#",
3788 Set_Entity
(Prefix
(N
), P_Name
);
3789 Find_Expanded_Name
(N
);
3792 P_Name
:= Entity
(Prefix
(N
));
3797 ("invalid prefix in selected component&", N
, P_Name
);
3798 Change_Selected_Component_To_Expanded_Name
(N
);
3799 Set_Entity
(N
, Any_Id
);
3800 Set_Etype
(N
, Any_Type
);
3803 Nam
:= New_Copy
(P
);
3804 Save_Interps
(P
, Nam
);
3806 Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
3808 Analyze_Selected_Component
(N
);
3812 -- Remaining cases generate various error messages
3815 -- Format node as expanded name, to avoid cascaded errors
3817 Change_Node
(N
, N_Expanded_Name
);
3819 Set_Entity
(N
, Any_Id
);
3820 Set_Etype
(N
, Any_Type
);
3822 -- Set_Selector_Name (N, Empty); ????
3824 -- Issue error message, but avoid this if error issued already.
3825 -- Use identifier of prefix if one is available.
3827 if P_Name
= Any_Id
then
3830 elsif Ekind
(P_Name
) = E_Void
then
3831 Premature_Usage
(P
);
3833 elsif Nkind
(P
) /= N_Attribute_Reference
then
3835 "invalid prefix in selected component&", P
);
3839 "invalid prefix in selected component", P
);
3844 -- If prefix is not the name of an entity, it must be an expression,
3845 -- whose type is appropriate for a record. This is determined by
3848 Analyze_Selected_Component
(N
);
3850 end Find_Selected_Component
;
3856 procedure Find_Type
(N
: Node_Id
) is
3866 elsif Nkind
(N
) = N_Attribute_Reference
then
3868 -- Class attribute. This is only valid in Ada 95 mode, but we don't
3869 -- do a check, since the tagged type referenced could only exist if
3870 -- we were in 95 mode when it was declared (or, if we were in Ada
3871 -- 83 mode, then an error message would already have been issued).
3873 if Attribute_Name
(N
) = Name_Class
then
3874 Check_Restriction
(No_Dispatch
, N
);
3875 Find_Type
(Prefix
(N
));
3877 -- Propagate error from bad prefix
3879 if Etype
(Prefix
(N
)) = Any_Type
then
3880 Set_Entity
(N
, Any_Type
);
3881 Set_Etype
(N
, Any_Type
);
3885 T
:= Base_Type
(Entity
(Prefix
(N
)));
3887 -- Case of non-tagged type
3889 if not Is_Tagged_Type
(T
) then
3890 if Ekind
(T
) = E_Incomplete_Type
then
3892 -- It is legal to denote the class type of an incomplete
3893 -- type. The full type will have to be tagged, of course.
3895 Set_Is_Tagged_Type
(T
);
3896 Make_Class_Wide_Type
(T
);
3897 Set_Entity
(N
, Class_Wide_Type
(T
));
3898 Set_Etype
(N
, Class_Wide_Type
(T
));
3900 elsif Ekind
(T
) = E_Private_Type
3901 and then not Is_Generic_Type
(T
)
3902 and then In_Private_Part
(Scope
(T
))
3904 -- The Class attribute can be applied to an untagged
3905 -- private type fulfilled by a tagged type prior to
3906 -- the full type declaration (but only within the
3907 -- parent package's private part). Create the class-wide
3908 -- type now and check that the full type is tagged
3909 -- later during its analysis. Note that we do not
3910 -- mark the private type as tagged, unlike the case
3911 -- of incomplete types, because the type must still
3912 -- appear untagged to outside units.
3914 if not Present
(Class_Wide_Type
(T
)) then
3915 Make_Class_Wide_Type
(T
);
3918 Set_Entity
(N
, Class_Wide_Type
(T
));
3919 Set_Etype
(N
, Class_Wide_Type
(T
));
3922 -- Should we introduce a type Any_Tagged and use
3923 -- Wrong_Type here, it would be a bit more consistent???
3926 ("tagged type required, found}",
3927 Prefix
(N
), First_Subtype
(T
));
3928 Set_Entity
(N
, Any_Type
);
3932 -- Case of tagged type
3935 C
:= Class_Wide_Type
(Entity
(Prefix
(N
)));
3936 Set_Entity_With_Style_Check
(N
, C
);
3937 Generate_Reference
(C
, N
);
3940 if From_With_Type
(C
)
3941 and then Nkind
(Parent
(N
)) /= N_Access_Definition
3942 and then not Analyzed
(T
)
3945 ("imported class-wide type can only be used" &
3946 " for access parameters", N
);
3950 -- Base attribute, allowed in Ada 95 mode only
3952 elsif Attribute_Name
(N
) = Name_Base
then
3953 if Ada_83
and then Comes_From_Source
(N
) then
3955 ("(Ada 83) Base attribute not allowed in subtype mark", N
);
3958 Find_Type
(Prefix
(N
));
3959 Typ
:= Entity
(Prefix
(N
));
3961 if Sloc
(Typ
) = Standard_Location
3962 and then Base_Type
(Typ
) = Typ
3963 and then Warn_On_Redundant_Constructs
3966 ("?redudant attribute, & is its own base type", N
, Typ
);
3969 T
:= Base_Type
(Typ
);
3973 -- Rewrite attribute reference with type itself (see similar
3974 -- processing in Analyze_Attribute, case Base)
3977 New_Reference_To
(Entity
(N
), Sloc
(N
)));
3981 -- All other attributes are invalid in a subtype mark
3984 Error_Msg_N
("invalid attribute in subtype mark", N
);
3990 if Is_Entity_Name
(N
) then
3991 T_Name
:= Entity
(N
);
3993 Error_Msg_N
("subtype mark required in this context", N
);
3994 Set_Etype
(N
, Any_Type
);
3998 if T_Name
= Any_Id
or else Etype
(N
) = Any_Type
then
4000 -- Undefined id. Make it into a valid type
4002 Set_Entity
(N
, Any_Type
);
4004 elsif not Is_Type
(T_Name
)
4005 and then T_Name
/= Standard_Void_Type
4007 Error_Msg_Sloc
:= Sloc
(T_Name
);
4008 Error_Msg_N
("subtype mark required in this context", N
);
4009 Error_Msg_NE
("\found & declared#", N
, T_Name
);
4010 Set_Entity
(N
, Any_Type
);
4013 T_Name
:= Get_Full_View
(T_Name
);
4015 if In_Open_Scopes
(T_Name
) then
4016 if Ekind
(Base_Type
(T_Name
)) = E_Task_Type
then
4017 Error_Msg_N
("task type cannot be used as type mark " &
4018 "within its own body", N
);
4020 Error_Msg_N
("type declaration cannot refer to itself", N
);
4023 Set_Etype
(N
, Any_Type
);
4024 Set_Entity
(N
, Any_Type
);
4025 Set_Error_Posted
(T_Name
);
4029 Set_Entity
(N
, T_Name
);
4030 Set_Etype
(N
, T_Name
);
4034 if Present
(Etype
(N
)) and then Comes_From_Source
(N
) then
4035 if Is_Fixed_Point_Type
(Etype
(N
)) then
4036 Check_Restriction
(No_Fixed_Point
, N
);
4037 elsif Is_Floating_Point_Type
(Etype
(N
)) then
4038 Check_Restriction
(No_Floating_Point
, N
);
4047 function Get_Full_View
(T_Name
: Entity_Id
) return Entity_Id
is
4049 if (Ekind
(T_Name
) = E_Incomplete_Type
4050 and then Present
(Full_View
(T_Name
)))
4052 return Full_View
(T_Name
);
4054 elsif Is_Class_Wide_Type
(T_Name
)
4055 and then Ekind
(Root_Type
(T_Name
)) = E_Incomplete_Type
4056 and then Present
(Full_View
(Root_Type
(T_Name
)))
4058 return Class_Wide_Type
(Full_View
(Root_Type
(T_Name
)));
4065 ------------------------------------
4066 -- Has_Implicit_Character_Literal --
4067 ------------------------------------
4069 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean is
4071 Found
: Boolean := False;
4072 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
4073 Priv_Id
: Entity_Id
:= Empty
;
4076 if Ekind
(P
) = E_Package
4077 and then not In_Open_Scopes
(P
)
4079 Priv_Id
:= First_Private_Entity
(P
);
4082 if P
= Standard_Standard
then
4083 Change_Selected_Component_To_Expanded_Name
(N
);
4084 Rewrite
(N
, Selector_Name
(N
));
4086 Set_Etype
(Original_Node
(N
), Standard_Character
);
4090 Id
:= First_Entity
(P
);
4093 and then Id
/= Priv_Id
4095 if Is_Character_Type
(Id
)
4096 and then (Root_Type
(Id
) = Standard_Character
4097 or else Root_Type
(Id
) = Standard_Wide_Character
)
4098 and then Id
= Base_Type
(Id
)
4100 -- We replace the node with the literal itself, resolve as a
4101 -- character, and set the type correctly.
4104 Change_Selected_Component_To_Expanded_Name
(N
);
4105 Rewrite
(N
, Selector_Name
(N
));
4108 Set_Etype
(Original_Node
(N
), Id
);
4112 -- More than one type derived from Character in given scope.
4113 -- Collect all possible interpretations.
4115 Add_One_Interp
(N
, Id
, Id
);
4123 end Has_Implicit_Character_Literal
;
4125 ---------------------------
4126 -- Has_Implicit_Operator --
4127 ---------------------------
4129 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean is
4130 Op_Id
: constant Name_Id
:= Chars
(Selector_Name
(N
));
4131 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
4133 Priv_Id
: Entity_Id
:= Empty
;
4135 procedure Add_Implicit_Operator
(T
: Entity_Id
);
4136 -- Add implicit interpretation to node N, using the type for which
4137 -- a predefined operator exists.
4139 ---------------------------
4140 -- Add_Implicit_Operator --
4141 ---------------------------
4143 procedure Add_Implicit_Operator
(T
: Entity_Id
) is
4144 Predef_Op
: Entity_Id
;
4147 Predef_Op
:= Current_Entity
(Selector_Name
(N
));
4149 while Present
(Predef_Op
)
4150 and then Scope
(Predef_Op
) /= Standard_Standard
4152 Predef_Op
:= Homonym
(Predef_Op
);
4155 if Nkind
(N
) = N_Selected_Component
then
4156 Change_Selected_Component_To_Expanded_Name
(N
);
4159 Add_One_Interp
(N
, Predef_Op
, T
);
4161 -- For operators with unary and binary interpretations, add both
4163 if Present
(Homonym
(Predef_Op
)) then
4164 Add_One_Interp
(N
, Homonym
(Predef_Op
), T
);
4166 end Add_Implicit_Operator
;
4168 -- Start of processing for Has_Implicit_Operator
4172 if Ekind
(P
) = E_Package
4173 and then not In_Open_Scopes
(P
)
4175 Priv_Id
:= First_Private_Entity
(P
);
4178 Id
:= First_Entity
(P
);
4182 -- Boolean operators: an implicit declaration exists if the scope
4183 -- contains a declaration for a derived Boolean type, or for an
4184 -- array of Boolean type.
4186 when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor
=>
4188 while Id
/= Priv_Id
loop
4190 if Valid_Boolean_Arg
(Id
)
4191 and then Id
= Base_Type
(Id
)
4193 Add_Implicit_Operator
(Id
);
4200 -- Equality: look for any non-limited type. Result is Boolean.
4202 when Name_Op_Eq | Name_Op_Ne
=>
4204 while Id
/= Priv_Id
loop
4207 and then not Is_Limited_Type
(Id
)
4208 and then Id
= Base_Type
(Id
)
4210 Add_Implicit_Operator
(Standard_Boolean
);
4217 -- Comparison operators: scalar type, or array of scalar.
4219 when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge
=>
4221 while Id
/= Priv_Id
loop
4222 if (Is_Scalar_Type
(Id
)
4223 or else (Is_Array_Type
(Id
)
4224 and then Is_Scalar_Type
(Component_Type
(Id
))))
4225 and then Id
= Base_Type
(Id
)
4227 Add_Implicit_Operator
(Standard_Boolean
);
4234 -- Arithmetic operators: any numeric type
4245 while Id
/= Priv_Id
loop
4246 if Is_Numeric_Type
(Id
)
4247 and then Id
= Base_Type
(Id
)
4249 Add_Implicit_Operator
(Id
);
4256 -- Concatenation: any one-dimensional array type
4258 when Name_Op_Concat
=>
4260 while Id
/= Priv_Id
loop
4261 if Is_Array_Type
(Id
) and then Number_Dimensions
(Id
) = 1
4262 and then Id
= Base_Type
(Id
)
4264 Add_Implicit_Operator
(Id
);
4271 -- What is the others condition here? Should we be using a
4272 -- subtype of Name_Id that would restrict to operators ???
4274 when others => null;
4278 -- If we fall through, then we do not have an implicit operator
4282 end Has_Implicit_Operator
;
4284 --------------------
4285 -- In_Open_Scopes --
4286 --------------------
4288 function In_Open_Scopes
(S
: Entity_Id
) return Boolean is
4290 -- Since there are several scope stacks maintained by Scope_Stack each
4291 -- delineated by Standard (see comments by definition of Scope_Stack)
4292 -- it is necessary to end the search when Standard is reached.
4294 for J
in reverse 0 .. Scope_Stack
.Last
loop
4295 if Scope_Stack
.Table
(J
).Entity
= S
then
4299 -- We need Is_Active_Stack_Base to tell us when to stop rather
4300 -- than checking for Standard_Standard because there are cases
4301 -- where Standard_Standard appears in the middle of the active
4302 -- set of scopes. This affects the declaration and overriding
4303 -- of private inherited operations in instantiations of generic
4306 exit when Scope_Stack
.Table
(J
).Is_Active_Stack_Base
;
4312 -----------------------------
4313 -- Inherit_Renamed_Profile --
4314 -----------------------------
4316 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
) is
4323 if Ekind
(Old_S
) = E_Operator
then
4325 New_F
:= First_Formal
(New_S
);
4327 while Present
(New_F
) loop
4328 Set_Etype
(New_F
, Base_Type
(Etype
(New_F
)));
4329 Next_Formal
(New_F
);
4332 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
4335 New_F
:= First_Formal
(New_S
);
4336 Old_F
:= First_Formal
(Old_S
);
4338 while Present
(New_F
) loop
4339 New_T
:= Etype
(New_F
);
4340 Old_T
:= Etype
(Old_F
);
4342 -- If the new type is a renaming of the old one, as is the
4343 -- case for actuals in instances, retain its name, to simplify
4344 -- later disambiguation.
4346 if Nkind
(Parent
(New_T
)) = N_Subtype_Declaration
4347 and then Is_Entity_Name
(Subtype_Indication
(Parent
(New_T
)))
4348 and then Entity
(Subtype_Indication
(Parent
(New_T
))) = Old_T
4352 Set_Etype
(New_F
, Old_T
);
4355 Next_Formal
(New_F
);
4356 Next_Formal
(Old_F
);
4359 if Ekind
(Old_S
) = E_Function
4360 or else Ekind
(Old_S
) = E_Enumeration_Literal
4362 Set_Etype
(New_S
, Etype
(Old_S
));
4365 end Inherit_Renamed_Profile
;
4371 procedure Initialize
is
4376 -------------------------
4377 -- Install_Use_Clauses --
4378 -------------------------
4380 procedure Install_Use_Clauses
(Clause
: Node_Id
) is
4381 U
: Node_Id
:= Clause
;
4386 while Present
(U
) loop
4388 -- Case of USE package
4390 if Nkind
(U
) = N_Use_Package_Clause
then
4391 P
:= First
(Names
(U
));
4393 while Present
(P
) loop
4396 if Ekind
(Id
) = E_Package
then
4399 Set_Redundant_Use
(P
, True);
4401 elsif Present
(Renamed_Object
(Id
))
4402 and then In_Use
(Renamed_Object
(Id
))
4404 Set_Redundant_Use
(P
, True);
4407 Use_One_Package
(Id
, U
);
4417 P
:= First
(Subtype_Marks
(U
));
4419 while Present
(P
) loop
4421 if Entity
(P
) /= Any_Type
then
4429 Next_Use_Clause
(U
);
4431 end Install_Use_Clauses
;
4433 -------------------------------------
4434 -- Is_Appropriate_For_Entry_Prefix --
4435 -------------------------------------
4437 function Is_Appropriate_For_Entry_Prefix
(T
: Entity_Id
) return Boolean is
4438 P_Type
: Entity_Id
:= T
;
4441 if Is_Access_Type
(P_Type
) then
4442 P_Type
:= Designated_Type
(P_Type
);
4445 return Is_Task_Type
(P_Type
) or else Is_Protected_Type
(P_Type
);
4446 end Is_Appropriate_For_Entry_Prefix
;
4448 -------------------------------
4449 -- Is_Appropriate_For_Record --
4450 -------------------------------
4452 function Is_Appropriate_For_Record
4456 function Has_Components
(T1
: Entity_Id
) return Boolean;
4457 -- Determine if given type has components (i.e. is either a record
4458 -- type or a type that has discriminants).
4460 function Has_Components
(T1
: Entity_Id
) return Boolean is
4462 return Is_Record_Type
(T1
)
4463 or else (Is_Private_Type
(T1
) and then Has_Discriminants
(T1
))
4464 or else (Is_Task_Type
(T1
) and then Has_Discriminants
(T1
));
4467 -- Start of processing for Is_Appropriate_For_Record
4472 and then (Has_Components
(T
)
4473 or else (Is_Access_Type
(T
)
4475 Has_Components
(Designated_Type
(T
))));
4476 end Is_Appropriate_For_Record
;
4482 procedure New_Scope
(S
: Entity_Id
) is
4486 if Ekind
(S
) = E_Void
then
4489 -- Set scope depth if not a non-concurrent type, and we have not
4490 -- yet set the scope depth. This means that we have the first
4491 -- occurrence of the scope, and this is where the depth is set.
4493 elsif (not Is_Type
(S
) or else Is_Concurrent_Type
(S
))
4494 and then not Scope_Depth_Set
(S
)
4496 if S
= Standard_Standard
then
4497 Set_Scope_Depth_Value
(S
, Uint_0
);
4499 elsif Is_Child_Unit
(S
) then
4500 Set_Scope_Depth_Value
(S
, Uint_1
);
4502 elsif not Is_Record_Type
(Current_Scope
) then
4503 if Ekind
(S
) = E_Loop
then
4504 Set_Scope_Depth_Value
(S
, Scope_Depth
(Current_Scope
));
4506 Set_Scope_Depth_Value
(S
, Scope_Depth
(Current_Scope
) + 1);
4511 Scope_Stack
.Increment_Last
;
4513 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
:= S
;
4515 Scope_Stack
.Table
(Scope_Stack
.Last
).Save_Scope_Suppress
:=
4518 Scope_Stack
.Table
(Scope_Stack
.Last
).Save_Entity_Suppress
:=
4519 Entity_Suppress
.Last
;
4521 if Scope_Stack
.Last
> Scope_Stack
.First
then
4522 Scope_Stack
.Table
(Scope_Stack
.Last
).Component_Alignment_Default
:=
4523 Scope_Stack
.Table
(Scope_Stack
.Last
- 1).Component_Alignment_Default
;
4526 Scope_Stack
.Table
(Scope_Stack
.Last
).Last_Subprogram_Name
:= null;
4527 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= False;
4528 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= Empty
;
4529 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
:= No_List
;
4531 (Scope_Stack
.Last
).Actions_To_Be_Wrapped_Before
:= No_List
;
4533 (Scope_Stack
.Last
).Actions_To_Be_Wrapped_After
:= No_List
;
4534 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
:= Empty
;
4535 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Active_Stack_Base
:= False;
4537 if Debug_Flag_W
then
4538 Write_Str
("--> new scope: ");
4539 Write_Name
(Chars
(Current_Scope
));
4540 Write_Str
(", Id=");
4541 Write_Int
(Int
(Current_Scope
));
4542 Write_Str
(", Depth=");
4543 Write_Int
(Int
(Scope_Stack
.Last
));
4547 -- Copy from Scope (S) the categorization flags to S, this is not
4548 -- done in case Scope (S) is Standard_Standard since propagation
4549 -- is from library unit entity inwards.
4551 if S
/= Standard_Standard
4552 and then Scope
(S
) /= Standard_Standard
4553 and then not Is_Child_Unit
(S
)
4557 if Nkind
(E
) not in N_Entity
then
4561 -- We only propagate inwards for library level entities,
4562 -- inner level subprograms do not inherit the categorization.
4564 if Is_Library_Level_Entity
(S
) then
4565 Set_Is_Pure
(S
, Is_Pure
(E
));
4566 Set_Is_Preelaborated
(S
, Is_Preelaborated
(E
));
4567 Set_Is_Remote_Call_Interface
(S
, Is_Remote_Call_Interface
(E
));
4568 Set_Is_Remote_Types
(S
, Is_Remote_Types
(E
));
4569 Set_Is_Shared_Passive
(S
, Is_Shared_Passive
(E
));
4578 procedure Pop_Scope
is
4582 if Debug_Flag_E
then
4587 Scope_Stack
.Table
(Scope_Stack
.Last
).Save_Scope_Suppress
;
4589 while Entity_Suppress
.Last
>
4590 Scope_Stack
.Table
(Scope_Stack
.Last
).Save_Entity_Suppress
4592 E
:= Entity_Suppress
.Table
(Entity_Suppress
.Last
).Entity
;
4594 case Entity_Suppress
.Table
(Entity_Suppress
.Last
).Check
is
4596 when Access_Check
=>
4597 Set_Suppress_Access_Checks
(E
, False);
4599 when Accessibility_Check
=>
4600 Set_Suppress_Accessibility_Checks
(E
, False);
4602 when Discriminant_Check
=>
4603 Set_Suppress_Discriminant_Checks
(E
, False);
4605 when Division_Check
=>
4606 Set_Suppress_Division_Checks
(E
, False);
4608 when Elaboration_Check
=>
4609 Set_Suppress_Elaboration_Checks
(E
, False);
4612 Set_Suppress_Index_Checks
(E
, False);
4614 when Length_Check
=>
4615 Set_Suppress_Length_Checks
(E
, False);
4617 when Overflow_Check
=>
4618 Set_Suppress_Overflow_Checks
(E
, False);
4621 Set_Suppress_Range_Checks
(E
, False);
4623 when Storage_Check
=>
4624 Set_Suppress_Storage_Checks
(E
, False);
4627 Set_Suppress_Tag_Checks
(E
, False);
4629 -- All_Checks should not appear here (since it is entered as a
4630 -- series of its separate checks). Bomb if it is encountered
4633 raise Program_Error
;
4636 Entity_Suppress
.Decrement_Last
;
4639 if Debug_Flag_W
then
4640 Write_Str
("--> exiting scope: ");
4641 Write_Name
(Chars
(Current_Scope
));
4642 Write_Str
(", Depth=");
4643 Write_Int
(Int
(Scope_Stack
.Last
));
4647 End_Use_Clauses
(Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
);
4649 -- If the actions to be wrapped are still there they will get lost
4650 -- causing incomplete code to be generated. It is better to abort in
4653 pragma Assert
(Scope_Stack
.Table
4654 (Scope_Stack
.Last
).Actions_To_Be_Wrapped_Before
= No_List
);
4656 pragma Assert
(Scope_Stack
.Table
4657 (Scope_Stack
.Last
).Actions_To_Be_Wrapped_After
= No_List
);
4659 -- Free last subprogram name if allocated, and pop scope
4661 Free
(Scope_Stack
.Table
(Scope_Stack
.Last
).Last_Subprogram_Name
);
4662 Scope_Stack
.Decrement_Last
;
4665 ---------------------
4666 -- Premature_Usage --
4667 ---------------------
4669 procedure Premature_Usage
(N
: Node_Id
) is
4670 Kind
: Node_Kind
:= Nkind
(Parent
(Entity
(N
)));
4671 E
: Entity_Id
:= Entity
(N
);
4674 -- Within an instance, the analysis of the actual for a formal object
4675 -- does not see the name of the object itself. This is significant
4676 -- only if the object is an aggregate, where its analysis does not do
4677 -- any name resolution on component associations. (see 4717-008). In
4678 -- such a case, look for the visible homonym on the chain.
4681 and then Present
(Homonym
(E
))
4686 and then not In_Open_Scopes
(Scope
(E
))
4693 Set_Etype
(N
, Etype
(E
));
4698 if Kind
= N_Component_Declaration
then
4700 ("component&! cannot be used before end of record declaration", N
);
4702 elsif Kind
= N_Parameter_Specification
then
4704 ("formal parameter&! cannot be used before end of specification",
4707 elsif Kind
= N_Discriminant_Specification
then
4709 ("discriminant&! cannot be used before end of discriminant part",
4712 elsif Kind
= N_Procedure_Specification
4713 or else Kind
= N_Function_Specification
4716 ("subprogram&! cannot be used before end of its declaration",
4720 ("object& cannot be used before end of its declaration!", N
);
4722 end Premature_Usage
;
4724 ------------------------
4725 -- Present_System_Aux --
4726 ------------------------
4728 function Present_System_Aux
(N
: Node_Id
:= Empty
) return Boolean is
4731 Unum
: Unit_Number_Type
;
4736 function Find_System
(C_Unit
: Node_Id
) return Entity_Id
;
4737 -- Scan context clause of compilation unit to find a with_clause
4740 function Find_System
(C_Unit
: Node_Id
) return Entity_Id
is
4741 With_Clause
: Node_Id
;
4744 With_Clause
:= First
(Context_Items
(C_Unit
));
4746 while Present
(With_Clause
) loop
4747 if (Nkind
(With_Clause
) = N_With_Clause
4748 and then Chars
(Name
(With_Clause
)) = Name_System
)
4749 and then Comes_From_Source
(With_Clause
)
4760 -- Start of processing for Present_System_Aux
4763 -- The child unit may have been loaded and analyzed already.
4765 if Present
(System_Aux_Id
) then
4768 -- If no previous pragma for System.Aux, nothing to load
4770 elsif No
(System_Extend_Pragma_Arg
) then
4773 -- Use the unit name given in the pragma to retrieve the unit.
4774 -- Verify that System itself appears in the context clause of the
4775 -- current compilation. If System is not present, an error will
4776 -- have been reported already.
4779 With_Sys
:= Find_System
(Cunit
(Current_Sem_Unit
));
4781 The_Unit
:= Unit
(Cunit
(Current_Sem_Unit
));
4784 and then (Nkind
(The_Unit
) = N_Package_Body
4785 or else (Nkind
(The_Unit
) = N_Subprogram_Body
4786 and then not Acts_As_Spec
(Cunit
(Current_Sem_Unit
))))
4788 With_Sys
:= Find_System
(Library_Unit
(Cunit
(Current_Sem_Unit
)));
4792 and then Present
(N
)
4794 -- If we are compiling a subunit, we need to examine its
4795 -- context as well (Current_Sem_Unit is the parent unit);
4797 The_Unit
:= Parent
(N
);
4799 while Nkind
(The_Unit
) /= N_Compilation_Unit
loop
4800 The_Unit
:= Parent
(The_Unit
);
4803 if Nkind
(Unit
(The_Unit
)) = N_Subunit
then
4804 With_Sys
:= Find_System
(The_Unit
);
4808 if No
(With_Sys
) then
4812 Loc
:= Sloc
(With_Sys
);
4813 Get_Name_String
(Chars
(Expression
(System_Extend_Pragma_Arg
)));
4814 Name_Buffer
(8 .. Name_Len
+ 7) := Name_Buffer
(1 .. Name_Len
);
4815 Name_Buffer
(1 .. 7) := "system.";
4816 Name_Buffer
(Name_Len
+ 8) := '%';
4817 Name_Buffer
(Name_Len
+ 9) := 's';
4818 Name_Len
:= Name_Len
+ 9;
4819 Aux_Name
:= Name_Find
;
4823 (Load_Name
=> Aux_Name
,
4826 Error_Node
=> With_Sys
);
4828 if Unum
/= No_Unit
then
4829 Semantics
(Cunit
(Unum
));
4831 Defining_Entity
(Specification
(Unit
(Cunit
(Unum
))));
4833 Withn
:= Make_With_Clause
(Loc
,
4835 Make_Expanded_Name
(Loc
,
4836 Chars
=> Chars
(System_Aux_Id
),
4838 New_Reference_To
(Scope
(System_Aux_Id
), Loc
),
4840 New_Reference_To
(System_Aux_Id
, Loc
)));
4842 Set_Entity
(Name
(Withn
), System_Aux_Id
);
4844 Set_Library_Unit
(Withn
, Cunit
(Unum
));
4845 Set_Corresponding_Spec
(Withn
, System_Aux_Id
);
4846 Set_First_Name
(Withn
, True);
4847 Set_Implicit_With
(Withn
, True);
4849 Insert_After
(With_Sys
, Withn
);
4850 Mark_Rewrite_Insertion
(Withn
);
4851 Set_Context_Installed
(Withn
);
4855 -- Here if unit load failed
4858 Error_Msg_Name_1
:= Name_System
;
4859 Error_Msg_Name_2
:= Chars
(Expression
(System_Extend_Pragma_Arg
));
4861 ("extension package `%.%` does not exist",
4862 Opt
.System_Extend_Pragma_Arg
);
4866 end Present_System_Aux
;
4868 -------------------------
4869 -- Restore_Scope_Stack --
4870 -------------------------
4872 procedure Restore_Scope_Stack
is
4875 Comp_Unit
: Node_Id
;
4876 In_Child
: Boolean := False;
4877 Full_Vis
: Boolean := True;
4880 -- Restore visibility of previous scope stack, if any.
4882 for J
in reverse 0 .. Scope_Stack
.Last
loop
4883 exit when Scope_Stack
.Table
(J
).Entity
= Standard_Standard
4884 or else No
(Scope_Stack
.Table
(J
).Entity
);
4886 S
:= Scope_Stack
.Table
(J
).Entity
;
4888 if not Is_Hidden_Open_Scope
(S
) then
4890 -- If the parent scope is hidden, its entities are hidden as
4891 -- well, unless the entity is the instantiation currently
4894 if not Is_Hidden_Open_Scope
(Scope
(S
))
4895 or else not Analyzed
(Parent
(S
))
4896 or else Scope
(S
) = Standard_Standard
4898 Set_Is_Immediately_Visible
(S
, True);
4901 E
:= First_Entity
(S
);
4903 while Present
(E
) loop
4904 if Is_Child_Unit
(E
) then
4905 Set_Is_Immediately_Visible
(E
,
4906 Is_Visible_Child_Unit
(E
) or else In_Open_Scopes
(E
));
4908 Set_Is_Immediately_Visible
(E
, True);
4913 if not Full_Vis
then
4914 exit when E
= First_Private_Entity
(S
);
4918 -- The visibility of child units (siblings of current compilation)
4919 -- must be restored in any case. Their declarations may appear
4920 -- after the private part of the parent.
4923 and then Present
(E
)
4925 while Present
(E
) loop
4926 if Is_Child_Unit
(E
) then
4927 Set_Is_Immediately_Visible
(E
,
4928 Is_Visible_Child_Unit
(E
) or else In_Open_Scopes
(E
));
4936 if Is_Child_Unit
(S
)
4937 and not In_Child
-- check only for current unit.
4941 -- restore visibility of parents according to whether the child
4942 -- is private and whether we are in its visible part.
4944 Comp_Unit
:= Parent
(Unit_Declaration_Node
(S
));
4946 if Nkind
(Comp_Unit
) = N_Compilation_Unit
4947 and then Private_Present
(Comp_Unit
)
4951 elsif (Ekind
(S
) = E_Package
4952 or else Ekind
(S
) = E_Generic_Package
)
4953 and then (In_Private_Part
(S
)
4954 or else In_Package_Body
(S
))
4958 elsif (Ekind
(S
) = E_Procedure
4959 or else Ekind
(S
) = E_Function
)
4960 and then Has_Completion
(S
)
4970 end Restore_Scope_Stack
;
4972 ----------------------
4973 -- Save_Scope_Stack --
4974 ----------------------
4976 procedure Save_Scope_Stack
is
4979 SS_Last
: constant Int
:= Scope_Stack
.Last
;
4982 if SS_Last
>= Scope_Stack
.First
4983 and then Scope_Stack
.Table
(SS_Last
).Entity
/= Standard_Standard
4986 -- If the call is from within a compilation unit, as when
4987 -- called from Rtsfind, make current entries in scope stack
4988 -- invisible while we analyze the new unit.
4990 for J
in reverse 0 .. SS_Last
loop
4991 exit when Scope_Stack
.Table
(J
).Entity
= Standard_Standard
4992 or else No
(Scope_Stack
.Table
(J
).Entity
);
4994 S
:= Scope_Stack
.Table
(J
).Entity
;
4995 Set_Is_Immediately_Visible
(S
, False);
4996 E
:= First_Entity
(S
);
4998 while Present
(E
) loop
4999 Set_Is_Immediately_Visible
(E
, False);
5005 end Save_Scope_Stack
;
5011 procedure Set_Use
(L
: List_Id
) is
5013 Pack_Name
: Node_Id
;
5021 while Present
(Decl
) loop
5022 if Nkind
(Decl
) = N_Use_Package_Clause
then
5023 Chain_Use_Clause
(Decl
);
5024 Pack_Name
:= First
(Names
(Decl
));
5026 while Present
(Pack_Name
) loop
5027 Pack
:= Entity
(Pack_Name
);
5029 if Ekind
(Pack
) = E_Package
5030 and then Applicable_Use
(Pack_Name
)
5032 Use_One_Package
(Pack
, Decl
);
5038 elsif Nkind
(Decl
) = N_Use_Type_Clause
then
5039 Chain_Use_Clause
(Decl
);
5040 Id
:= First
(Subtype_Marks
(Decl
));
5042 while Present
(Id
) loop
5043 if Entity
(Id
) /= Any_Type
then
5056 ---------------------
5057 -- Use_One_Package --
5058 ---------------------
5060 procedure Use_One_Package
(P
: Entity_Id
; N
: Node_Id
) is
5063 Current_Instance
: Entity_Id
:= Empty
;
5067 if Ekind
(P
) /= E_Package
then
5073 if From_With_Type
(P
) then
5074 Error_Msg_N
("imported package cannot appear in use clause", N
);
5077 -- Find enclosing instance, if any.
5080 Current_Instance
:= Current_Scope
;
5082 while not Is_Generic_Instance
(Current_Instance
) loop
5083 Current_Instance
:= Scope
(Current_Instance
);
5086 if No
(Hidden_By_Use_Clause
(N
)) then
5087 Set_Hidden_By_Use_Clause
(N
, New_Elmt_List
);
5091 -- If unit is a package renaming, indicate that the renamed
5092 -- package is also in use (the flags on both entities must
5093 -- remain consistent, and a subsequent use of either of them
5094 -- should be recognized as redundant).
5096 if Present
(Renamed_Object
(P
)) then
5097 Set_In_Use
(Renamed_Object
(P
));
5098 Real_P
:= Renamed_Object
(P
);
5103 -- Loop through entities in one package making them potentially
5106 Id
:= First_Entity
(P
);
5108 and then Id
/= First_Private_Entity
(P
)
5110 Prev
:= Current_Entity
(Id
);
5112 while Present
(Prev
) loop
5113 if Is_Immediately_Visible
(Prev
)
5114 and then (not Is_Overloadable
(Prev
)
5115 or else not Is_Overloadable
(Id
)
5116 or else (Type_Conformant
(Id
, Prev
)))
5118 if No
(Current_Instance
) then
5120 -- Potentially use-visible entity remains hidden
5122 goto Next_Usable_Entity
;
5124 -- A use clause within an instance hides outer global
5125 -- entities, which are not used to resolve local entities
5126 -- in the instance. Note that the predefined entities in
5127 -- Standard could not have been hidden in the generic by
5128 -- a use clause, and therefore remain visible. Other
5129 -- compilation units whose entities appear in Standard must
5130 -- be hidden in an instance.
5132 -- To determine whether an entity is external to the instance
5133 -- we compare the scope depth of its scope with that of the
5134 -- current instance. However, a generic actual of a subprogram
5135 -- instance is declared in the wrapper package but will not be
5136 -- hidden by a use-visible entity.
5138 elsif not Is_Hidden
(Id
)
5139 and then not Is_Wrapper_Package
(Scope
(Prev
))
5140 and then Scope_Depth
(Scope
(Prev
)) <
5141 Scope_Depth
(Current_Instance
)
5142 and then (Scope
(Prev
) /= Standard_Standard
5143 or else Sloc
(Prev
) > Standard_Location
)
5145 Set_Is_Potentially_Use_Visible
(Id
);
5146 Set_Is_Immediately_Visible
(Prev
, False);
5147 Append_Elmt
(Prev
, Hidden_By_Use_Clause
(N
));
5150 -- A user-defined operator is not use-visible if the
5151 -- predefined operator for the type is immediately visible,
5152 -- which is the case if the type of the operand is in an open
5153 -- scope. This does not apply to user-defined operators that
5154 -- have operands of different types, because the predefined
5155 -- mixed mode operations (multiplication and division) apply to
5156 -- universal types and do not hide anything.
5158 elsif Ekind
(Prev
) = E_Operator
5159 and then Operator_Matches_Spec
(Prev
, Id
)
5160 and then In_Open_Scopes
5161 (Scope
(Base_Type
(Etype
(First_Formal
(Id
)))))
5162 and then (No
(Next_Formal
(First_Formal
(Id
)))
5163 or else Etype
(First_Formal
(Id
))
5164 = Etype
(Next_Formal
(First_Formal
(Id
)))
5165 or else Chars
(Prev
) = Name_Op_Expon
)
5167 goto Next_Usable_Entity
;
5170 Prev
:= Homonym
(Prev
);
5173 -- On exit, we know entity is not hidden, unless it is private.
5175 if not Is_Hidden
(Id
)
5176 and then ((not Is_Child_Unit
(Id
))
5177 or else Is_Visible_Child_Unit
(Id
))
5179 Set_Is_Potentially_Use_Visible
(Id
);
5181 if Is_Private_Type
(Id
)
5182 and then Present
(Full_View
(Id
))
5184 Set_Is_Potentially_Use_Visible
(Full_View
(Id
));
5188 <<Next_Usable_Entity
>>
5192 -- Child units are also made use-visible by a use clause, but they
5193 -- may appear after all visible declarations in the parent entity list.
5195 while Present
(Id
) loop
5197 if Is_Child_Unit
(Id
)
5198 and then Is_Visible_Child_Unit
(Id
)
5200 Set_Is_Potentially_Use_Visible
(Id
);
5206 if Chars
(Real_P
) = Name_System
5207 and then Scope
(Real_P
) = Standard_Standard
5208 and then Present_System_Aux
(N
)
5210 Use_One_Package
(System_Aux_Id
, N
);
5213 end Use_One_Package
;
5219 procedure Use_One_Type
(Id
: Node_Id
) is
5225 -- It is the type determined by the subtype mark (8.4(8)) whose
5226 -- operations become potentially use-visible.
5228 T
:= Base_Type
(Entity
(Id
));
5230 -- Save current visibility status of type, before setting.
5233 (Id
, In_Use
(T
) or else Is_Potentially_Use_Visible
(T
));
5235 if In_Open_Scopes
(Scope
(T
)) then
5238 elsif not Redundant_Use
(Id
) then
5240 Op_List
:= Collect_Primitive_Operations
(T
);
5241 Elmt
:= First_Elmt
(Op_List
);
5243 while Present
(Elmt
) loop
5245 if (Nkind
(Node
(Elmt
)) = N_Defining_Operator_Symbol
5246 or else Chars
(Node
(Elmt
)) in Any_Operator_Name
)
5247 and then not Is_Hidden
(Node
(Elmt
))
5249 Set_Is_Potentially_Use_Visible
(Node
(Elmt
));
5261 procedure Write_Info
is
5262 Id
: Entity_Id
:= First_Entity
(Current_Scope
);
5265 -- No point in dumping standard entities
5267 if Current_Scope
= Standard_Standard
then
5271 Write_Str
("========================================================");
5273 Write_Str
(" Defined Entities in ");
5274 Write_Name
(Chars
(Current_Scope
));
5276 Write_Str
("========================================================");
5280 Write_Str
("-- none --");
5284 while Present
(Id
) loop
5285 Write_Entity_Info
(Id
, " ");
5290 if Scope
(Current_Scope
) = Standard_Standard
then
5292 -- Print information on the current unit itself
5294 Write_Entity_Info
(Current_Scope
, " ");
5304 procedure Write_Scopes
is
5308 for J
in reverse 1 .. Scope_Stack
.Last
loop
5309 S
:= Scope_Stack
.Table
(J
).Entity
;
5310 Write_Int
(Int
(S
));
5311 Write_Str
(" === ");
5312 Write_Name
(Chars
(S
));