1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Exp_Disp
; use Exp_Disp
;
32 with Exp_Tss
; use Exp_Tss
;
33 with Exp_Util
; use Exp_Util
;
34 with Freeze
; use Freeze
;
35 with Ghost
; use Ghost
;
36 with Impunit
; use Impunit
;
38 with Lib
.Load
; use Lib
.Load
;
39 with Lib
.Xref
; use Lib
.Xref
;
40 with Namet
; use Namet
;
41 with Namet
.Sp
; use Namet
.Sp
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Output
; use Output
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Cat
; use Sem_Cat
;
52 with Sem_Ch3
; use Sem_Ch3
;
53 with Sem_Ch4
; use Sem_Ch4
;
54 with Sem_Ch6
; use Sem_Ch6
;
55 with Sem_Ch12
; use Sem_Ch12
;
56 with Sem_Ch13
; use Sem_Ch13
;
57 with Sem_Dim
; use Sem_Dim
;
58 with Sem_Disp
; use Sem_Disp
;
59 with Sem_Dist
; use Sem_Dist
;
60 with Sem_Elab
; use Sem_Elab
;
61 with Sem_Eval
; use Sem_Eval
;
62 with Sem_Res
; use Sem_Res
;
63 with Sem_Util
; use Sem_Util
;
64 with Sem_Type
; use Sem_Type
;
65 with Stand
; use Stand
;
66 with Sinfo
; use Sinfo
;
67 with Sinfo
.CN
; use Sinfo
.CN
;
68 with Snames
; use Snames
;
71 with Tbuild
; use Tbuild
;
72 with Uintp
; use Uintp
;
74 package body Sem_Ch8
is
76 ------------------------------------
77 -- Visibility and Name Resolution --
78 ------------------------------------
80 -- This package handles name resolution and the collection of possible
81 -- interpretations for overloaded names, prior to overload resolution.
83 -- Name resolution is the process that establishes a mapping between source
84 -- identifiers and the entities they denote at each point in the program.
85 -- Each entity is represented by a defining occurrence. Each identifier
86 -- that denotes an entity points to the corresponding defining occurrence.
87 -- This is the entity of the applied occurrence. Each occurrence holds
88 -- an index into the names table, where source identifiers are stored.
90 -- Each entry in the names table for an identifier or designator uses the
91 -- Info pointer to hold a link to the currently visible entity that has
92 -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id
93 -- in package Sem_Util). The visibility is initialized at the beginning of
94 -- semantic processing to make entities in package Standard immediately
95 -- visible. The visibility table is used in a more subtle way when
96 -- compiling subunits (see below).
98 -- Entities that have the same name (i.e. homonyms) are chained. In the
99 -- case of overloaded entities, this chain holds all the possible meanings
100 -- of a given identifier. The process of overload resolution uses type
101 -- information to select from this chain the unique meaning of a given
104 -- Entities are also chained in their scope, through the Next_Entity link.
105 -- As a consequence, the name space is organized as a sparse matrix, where
106 -- each row corresponds to a scope, and each column to a source identifier.
107 -- Open scopes, that is to say scopes currently being compiled, have their
108 -- corresponding rows of entities in order, innermost scope first.
110 -- The scopes of packages that are mentioned in context clauses appear in
111 -- no particular order, interspersed among open scopes. This is because
112 -- in the course of analyzing the context of a compilation, a package
113 -- declaration is first an open scope, and subsequently an element of the
114 -- context. If subunits or child units are present, a parent unit may
115 -- appear under various guises at various times in the compilation.
117 -- When the compilation of the innermost scope is complete, the entities
118 -- defined therein are no longer visible. If the scope is not a package
119 -- declaration, these entities are never visible subsequently, and can be
120 -- removed from visibility chains. If the scope is a package declaration,
121 -- its visible declarations may still be accessible. Therefore the entities
122 -- defined in such a scope are left on the visibility chains, and only
123 -- their visibility (immediately visibility or potential use-visibility)
126 -- The ordering of homonyms on their chain does not necessarily follow
127 -- the order of their corresponding scopes on the scope stack. For
128 -- example, if package P and the enclosing scope both contain entities
129 -- named E, then when compiling the package body the chain for E will
130 -- hold the global entity first, and the local one (corresponding to
131 -- the current inner scope) next. As a result, name resolution routines
132 -- do not assume any relative ordering of the homonym chains, either
133 -- for scope nesting or to order of appearance of context clauses.
135 -- When compiling a child unit, entities in the parent scope are always
136 -- immediately visible. When compiling the body of a child unit, private
137 -- entities in the parent must also be made immediately visible. There
138 -- are separate routines to make the visible and private declarations
139 -- visible at various times (see package Sem_Ch7).
141 -- +--------+ +-----+
142 -- | In use |-------->| EU1 |-------------------------->
143 -- +--------+ +-----+
145 -- +--------+ +-----+ +-----+
146 -- | Stand. |---------------->| ES1 |--------------->| ES2 |--->
147 -- +--------+ +-----+ +-----+
149 -- +---------+ | +-----+
150 -- | with'ed |------------------------------>| EW2 |--->
151 -- +---------+ | +-----+
153 -- +--------+ +-----+ +-----+
154 -- | Scope2 |---------------->| E12 |--------------->| E22 |--->
155 -- +--------+ +-----+ +-----+
157 -- +--------+ +-----+ +-----+
158 -- | Scope1 |---------------->| E11 |--------------->| E12 |--->
159 -- +--------+ +-----+ +-----+
163 -- | | with'ed |----------------------------------------->
167 -- (innermost first) | |
168 -- +----------------------------+
169 -- Names table => | Id1 | | | | Id2 |
170 -- +----------------------------+
172 -- Name resolution must deal with several syntactic forms: simple names,
173 -- qualified names, indexed names, and various forms of calls.
175 -- Each identifier points to an entry in the names table. The resolution
176 -- of a simple name consists in traversing the homonym chain, starting
177 -- from the names table. If an entry is immediately visible, it is the one
178 -- designated by the identifier. If only potentially use-visible entities
179 -- are on the chain, we must verify that they do not hide each other. If
180 -- the entity we find is overloadable, we collect all other overloadable
181 -- entities on the chain as long as they are not hidden.
183 -- To resolve expanded names, we must find the entity at the intersection
184 -- of the entity chain for the scope (the prefix) and the homonym chain
185 -- for the selector. In general, homonym chains will be much shorter than
186 -- entity chains, so it is preferable to start from the names table as
187 -- well. If the entity found is overloadable, we must collect all other
188 -- interpretations that are defined in the scope denoted by the prefix.
190 -- For records, protected types, and tasks, their local entities are
191 -- removed from visibility chains on exit from the corresponding scope.
192 -- From the outside, these entities are always accessed by selected
193 -- notation, and the entity chain for the record type, protected type,
194 -- etc. is traversed sequentially in order to find the designated entity.
196 -- The discriminants of a type and the operations of a protected type or
197 -- task are unchained on exit from the first view of the type, (such as
198 -- a private or incomplete type declaration, or a protected type speci-
199 -- fication) and re-chained when compiling the second view.
201 -- In the case of operators, we do not make operators on derived types
202 -- explicit. As a result, the notation P."+" may denote either a user-
203 -- defined function with name "+", or else an implicit declaration of the
204 -- operator "+" in package P. The resolution of expanded names always
205 -- tries to resolve an operator name as such an implicitly defined entity,
206 -- in addition to looking for explicit declarations.
208 -- All forms of names that denote entities (simple names, expanded names,
209 -- character literals in some cases) have a Entity attribute, which
210 -- identifies the entity denoted by the name.
212 ---------------------
213 -- The Scope Stack --
214 ---------------------
216 -- The Scope stack keeps track of the scopes currently been compiled.
217 -- Every entity that contains declarations (including records) is placed
218 -- on the scope stack while it is being processed, and removed at the end.
219 -- Whenever a non-package scope is exited, the entities defined therein
220 -- are removed from the visibility table, so that entities in outer scopes
221 -- become visible (see previous description). On entry to Sem, the scope
222 -- stack only contains the package Standard. As usual, subunits complicate
223 -- this picture ever so slightly.
225 -- The Rtsfind mechanism can force a call to Semantics while another
226 -- compilation is in progress. The unit retrieved by Rtsfind must be
227 -- compiled in its own context, and has no access to the visibility of
228 -- the unit currently being compiled. The procedures Save_Scope_Stack and
229 -- Restore_Scope_Stack make entities in current open scopes invisible
230 -- before compiling the retrieved unit, and restore the compilation
231 -- environment afterwards.
233 ------------------------
234 -- Compiling subunits --
235 ------------------------
237 -- Subunits must be compiled in the environment of the corresponding stub,
238 -- that is to say with the same visibility into the parent (and its
239 -- context) that is available at the point of the stub declaration, but
240 -- with the additional visibility provided by the context clause of the
241 -- subunit itself. As a result, compilation of a subunit forces compilation
242 -- of the parent (see description in lib-). At the point of the stub
243 -- declaration, Analyze is called recursively to compile the proper body of
244 -- the subunit, but without reinitializing the names table, nor the scope
245 -- stack (i.e. standard is not pushed on the stack). In this fashion the
246 -- context of the subunit is added to the context of the parent, and the
247 -- subunit is compiled in the correct environment. Note that in the course
248 -- of processing the context of a subunit, Standard will appear twice on
249 -- the scope stack: once for the parent of the subunit, and once for the
250 -- unit in the context clause being compiled. However, the two sets of
251 -- entities are not linked by homonym chains, so that the compilation of
252 -- any context unit happens in a fresh visibility environment.
254 -------------------------------
255 -- Processing of USE Clauses --
256 -------------------------------
258 -- Every defining occurrence has a flag indicating if it is potentially use
259 -- visible. Resolution of simple names examines this flag. The processing
260 -- of use clauses consists in setting this flag on all visible entities
261 -- defined in the corresponding package. On exit from the scope of the use
262 -- clause, the corresponding flag must be reset. However, a package may
263 -- appear in several nested use clauses (pathological but legal, alas)
264 -- which forces us to use a slightly more involved scheme:
266 -- a) The defining occurrence for a package holds a flag -In_Use- to
267 -- indicate that it is currently in the scope of a use clause. If a
268 -- redundant use clause is encountered, then the corresponding occurrence
269 -- of the package name is flagged -Redundant_Use-.
271 -- b) On exit from a scope, the use clauses in its declarative part are
272 -- scanned. The visibility flag is reset in all entities declared in
273 -- package named in a use clause, as long as the package is not flagged
274 -- as being in a redundant use clause (in which case the outer use
275 -- clause is still in effect, and the direct visibility of its entities
276 -- must be retained).
278 -- Note that entities are not removed from their homonym chains on exit
279 -- from the package specification. A subsequent use clause does not need
280 -- to rechain the visible entities, but only to establish their direct
283 -----------------------------------
284 -- Handling private declarations --
285 -----------------------------------
287 -- The principle that each entity has a single defining occurrence clashes
288 -- with the presence of two separate definitions for private types: the
289 -- first is the private type declaration, and second is the full type
290 -- declaration. It is important that all references to the type point to
291 -- the same defining occurrence, namely the first one. To enforce the two
292 -- separate views of the entity, the corresponding information is swapped
293 -- between the two declarations. Outside of the package, the defining
294 -- occurrence only contains the private declaration information, while in
295 -- the private part and the body of the package the defining occurrence
296 -- contains the full declaration. To simplify the swap, the defining
297 -- occurrence that currently holds the private declaration points to the
298 -- full declaration. During semantic processing the defining occurrence
299 -- also points to a list of private dependents, that is to say access types
300 -- or composite types whose designated types or component types are
301 -- subtypes or derived types of the private type in question. After the
302 -- full declaration has been seen, the private dependents are updated to
303 -- indicate that they have full definitions.
305 ------------------------------------
306 -- Handling of Undefined Messages --
307 ------------------------------------
309 -- In normal mode, only the first use of an undefined identifier generates
310 -- a message. The table Urefs is used to record error messages that have
311 -- been issued so that second and subsequent ones do not generate further
312 -- messages. However, the second reference causes text to be added to the
313 -- original undefined message noting "(more references follow)". The
314 -- full error list option (-gnatf) forces messages to be generated for
315 -- every reference and disconnects the use of this table.
317 type Uref_Entry
is record
319 -- Node for identifier for which original message was posted. The
320 -- Chars field of this identifier is used to detect later references
321 -- to the same identifier.
324 -- Records error message Id of original undefined message. Reset to
325 -- No_Error_Msg after the second occurrence, where it is used to add
326 -- text to the original message as described above.
329 -- Set if the message is not visible rather than undefined
332 -- Records location of error message. Used to make sure that we do
333 -- not consider a, b : undefined as two separate instances, which
334 -- would otherwise happen, since the parser converts this sequence
335 -- to a : undefined; b : undefined.
339 package Urefs
is new Table
.Table
(
340 Table_Component_Type
=> Uref_Entry
,
341 Table_Index_Type
=> Nat
,
342 Table_Low_Bound
=> 1,
344 Table_Increment
=> 100,
345 Table_Name
=> "Urefs");
347 Candidate_Renaming
: Entity_Id
;
348 -- Holds a candidate interpretation that appears in a subprogram renaming
349 -- declaration and does not match the given specification, but matches at
350 -- least on the first formal. Allows better error message when given
351 -- specification omits defaulted parameters, a common error.
353 -----------------------
354 -- Local Subprograms --
355 -----------------------
357 procedure Analyze_Generic_Renaming
360 -- Common processing for all three kinds of generic renaming declarations.
361 -- Enter new name and indicate that it renames the generic unit.
363 procedure Analyze_Renamed_Character
367 -- Renamed entity is given by a character literal, which must belong
368 -- to the return type of the new entity. Is_Body indicates whether the
369 -- declaration is a renaming_as_body. If the original declaration has
370 -- already been frozen (because of an intervening body, e.g.) the body of
371 -- the function must be built now. The same applies to the following
372 -- various renaming procedures.
374 procedure Analyze_Renamed_Dereference
378 -- Renamed entity is given by an explicit dereference. Prefix must be a
379 -- conformant access_to_subprogram type.
381 procedure Analyze_Renamed_Entry
385 -- If the renamed entity in a subprogram renaming is an entry or protected
386 -- subprogram, build a body for the new entity whose only statement is a
387 -- call to the renamed entity.
389 procedure Analyze_Renamed_Family_Member
393 -- Used when the renamed entity is an indexed component. The prefix must
394 -- denote an entry family.
396 procedure Analyze_Renamed_Primitive_Operation
400 -- If the renamed entity in a subprogram renaming is a primitive operation
401 -- or a class-wide operation in prefix form, save the target object,
402 -- which must be added to the list of actuals in any subsequent call.
403 -- The renaming operation is intrinsic because the compiler must in
404 -- fact generate a wrapper for it (6.3.1 (10 1/2)).
406 procedure Attribute_Renaming
(N
: Node_Id
);
407 -- Analyze renaming of attribute as subprogram. The renaming declaration N
408 -- is rewritten as a subprogram body that returns the attribute reference
409 -- applied to the formals of the function.
411 procedure Set_Entity_Or_Discriminal
(N
: Node_Id
; E
: Entity_Id
);
412 -- Set Entity, with style check if need be. For a discriminant reference,
413 -- replace by the corresponding discriminal, i.e. the parameter of the
414 -- initialization procedure that corresponds to the discriminant.
416 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
);
417 -- A renaming_as_body may occur after the entity of the original decla-
418 -- ration has been frozen. In that case, the body of the new entity must
419 -- be built now, because the usual mechanism of building the renamed
420 -- body at the point of freezing will not work. Subp is the subprogram
421 -- for which N provides the Renaming_As_Body.
423 procedure Check_In_Previous_With_Clause
426 -- N is a use_package clause and Nam the package name, or N is a use_type
427 -- clause and Nam is the prefix of the type name. In either case, verify
428 -- that the package is visible at that point in the context: either it
429 -- appears in a previous with_clause, or because it is a fully qualified
430 -- name and the root ancestor appears in a previous with_clause.
432 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
);
433 -- Verify that the entity in a renaming declaration that is a library unit
434 -- is itself a library unit and not a nested unit or subunit. Also check
435 -- that if the renaming is a child unit of a generic parent, then the
436 -- renamed unit must also be a child unit of that parent. Finally, verify
437 -- that a renamed generic unit is not an implicit child declared within
438 -- an instance of the parent.
440 procedure Chain_Use_Clause
(N
: Node_Id
);
441 -- Chain use clause onto list of uses clauses headed by First_Use_Clause in
442 -- the proper scope table entry. This is usually the current scope, but it
443 -- will be an inner scope when installing the use clauses of the private
444 -- declarations of a parent unit prior to compiling the private part of a
445 -- child unit. This chain is traversed when installing/removing use clauses
446 -- when compiling a subunit or instantiating a generic body on the fly,
447 -- when it is necessary to save and restore full environments.
449 function Enclosing_Instance
return Entity_Id
;
450 -- In an instance nested within another one, several semantic checks are
451 -- unnecessary because the legality of the nested instance has been checked
452 -- in the enclosing generic unit. This applies in particular to legality
453 -- checks on actuals for formal subprograms of the inner instance, which
454 -- are checked as subprogram renamings, and may be complicated by confusion
455 -- in private/full views. This function returns the instance enclosing the
456 -- current one if there is such, else it returns Empty.
458 -- If the renaming determines the entity for the default of a formal
459 -- subprogram nested within another instance, choose the innermost
460 -- candidate. This is because if the formal has a box, and we are within
461 -- an enclosing instance where some candidate interpretations are local
462 -- to this enclosing instance, we know that the default was properly
463 -- resolved when analyzing the generic, so we prefer the local
464 -- candidates to those that are external. This is not always the case
465 -- but is a reasonable heuristic on the use of nested generics. The
466 -- proper solution requires a full renaming model.
468 function Entity_Of_Unit
(U
: Node_Id
) return Entity_Id
;
469 -- Return the appropriate entity for determining which unit has a deeper
470 -- scope: the defining entity for U, unless U is a package instance, in
471 -- which case we retrieve the entity of the instance spec.
473 procedure Find_Expanded_Name
(N
: Node_Id
);
474 -- The input is a selected component known to be an expanded name. Verify
475 -- legality of selector given the scope denoted by prefix, and change node
476 -- N into a expanded name with a properly set Entity field.
478 function Find_Most_Prev
(Use_Clause
: Node_Id
) return Node_Id
;
479 -- Find the most previous use clause (that is, the first one to appear in
480 -- the source) by traversing the previous clause chain that exists in both
481 -- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes.
482 -- ??? a better subprogram name is in order
484 function Find_Renamed_Entity
488 Is_Actual
: Boolean := False) return Entity_Id
;
489 -- Find the renamed entity that corresponds to the given parameter profile
490 -- in a subprogram renaming declaration. The renamed entity may be an
491 -- operator, a subprogram, an entry, or a protected operation. Is_Actual
492 -- indicates that the renaming is the one generated for an actual subpro-
493 -- gram in an instance, for which special visibility checks apply.
495 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean;
496 -- Find a type derived from Character or Wide_Character in the prefix of N.
497 -- Used to resolved qualified names whose selector is a character literal.
499 function Has_Private_With
(E
: Entity_Id
) return Boolean;
500 -- Ada 2005 (AI-262): Determines if the current compilation unit has a
501 -- private with on E.
503 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean;
504 -- N is an expanded name whose selector is an operator name (e.g. P."+").
505 -- declarative part contains an implicit declaration of an operator if it
506 -- has a declaration of a type to which one of the predefined operators
507 -- apply. The existence of this routine is an implementation artifact. A
508 -- more straightforward but more space-consuming choice would be to make
509 -- all inherited operators explicit in the symbol table.
511 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
);
512 -- A subprogram defined by a renaming declaration inherits the parameter
513 -- profile of the renamed entity. The subtypes given in the subprogram
514 -- specification are discarded and replaced with those of the renamed
515 -- subprogram, which are then used to recheck the default values.
517 function Is_Appropriate_For_Entry_Prefix
(T
: Entity_Id
) return Boolean;
518 -- True if it is of a task type, a protected type, or else an access to one
521 function Is_Appropriate_For_Record
(T
: Entity_Id
) return Boolean;
522 -- Prefix is appropriate for record if it is of a record type, or an access
525 function Most_Descendant_Use_Clause
526 (Clause1
: Entity_Id
;
527 Clause2
: Entity_Id
) return Entity_Id
;
528 -- Determine which use clause parameter is the most descendant in terms of
530 -- ??? a better subprogram name is in order
532 procedure Premature_Usage
(N
: Node_Id
);
533 -- Diagnose usage of an entity before it is visible
535 procedure Use_One_Package
537 Pack_Name
: Entity_Id
:= Empty
;
538 Force
: Boolean := False);
539 -- Make visible entities declared in package P potentially use-visible
540 -- in the current context. Also used in the analysis of subunits, when
541 -- re-installing use clauses of parent units. N is the use_clause that
542 -- names P (and possibly other packages).
544 procedure Use_One_Type
546 Installed
: Boolean := False;
547 Force
: Boolean := False);
548 -- Id is the subtype mark from a use_type_clause. This procedure makes
549 -- the primitive operators of the type potentially use-visible. The
550 -- boolean flag Installed indicates that the clause is being reinstalled
551 -- after previous analysis, and primitive operations are already chained
552 -- on the Used_Operations list of the clause.
554 procedure Write_Info
;
555 -- Write debugging information on entities declared in current scope
557 --------------------------------
558 -- Analyze_Exception_Renaming --
559 --------------------------------
561 -- The language only allows a single identifier, but the tree holds an
562 -- identifier list. The parser has already issued an error message if
563 -- there is more than one element in the list.
565 procedure Analyze_Exception_Renaming
(N
: Node_Id
) is
566 Id
: constant Entity_Id
:= Defining_Entity
(N
);
567 Nam
: constant Node_Id
:= Name
(N
);
570 Check_SPARK_05_Restriction
("exception renaming is not allowed", N
);
575 Set_Ekind
(Id
, E_Exception
);
576 Set_Etype
(Id
, Standard_Exception_Type
);
577 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
579 if Is_Entity_Name
(Nam
)
580 and then Present
(Entity
(Nam
))
581 and then Ekind
(Entity
(Nam
)) = E_Exception
583 if Present
(Renamed_Object
(Entity
(Nam
))) then
584 Set_Renamed_Object
(Id
, Renamed_Object
(Entity
(Nam
)));
586 Set_Renamed_Object
(Id
, Entity
(Nam
));
589 -- The exception renaming declaration may become Ghost if it renames
592 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
594 Error_Msg_N
("invalid exception name in renaming", Nam
);
597 -- Implementation-defined aspect specifications can appear in a renaming
598 -- declaration, but not language-defined ones. The call to procedure
599 -- Analyze_Aspect_Specifications will take care of this error check.
601 if Has_Aspects
(N
) then
602 Analyze_Aspect_Specifications
(N
, Id
);
604 end Analyze_Exception_Renaming
;
606 ---------------------------
607 -- Analyze_Expanded_Name --
608 ---------------------------
610 procedure Analyze_Expanded_Name
(N
: Node_Id
) is
612 -- If the entity pointer is already set, this is an internal node, or a
613 -- node that is analyzed more than once, after a tree modification. In
614 -- such a case there is no resolution to perform, just set the type. In
615 -- either case, start by analyzing the prefix.
617 Analyze
(Prefix
(N
));
619 if Present
(Entity
(N
)) then
620 if Is_Type
(Entity
(N
)) then
621 Set_Etype
(N
, Entity
(N
));
623 Set_Etype
(N
, Etype
(Entity
(N
)));
627 Find_Expanded_Name
(N
);
630 -- In either case, propagate dimension of entity to expanded name
632 Analyze_Dimension
(N
);
633 end Analyze_Expanded_Name
;
635 ---------------------------------------
636 -- Analyze_Generic_Function_Renaming --
637 ---------------------------------------
639 procedure Analyze_Generic_Function_Renaming
(N
: Node_Id
) is
641 Analyze_Generic_Renaming
(N
, E_Generic_Function
);
642 end Analyze_Generic_Function_Renaming
;
644 --------------------------------------
645 -- Analyze_Generic_Package_Renaming --
646 --------------------------------------
648 procedure Analyze_Generic_Package_Renaming
(N
: Node_Id
) is
650 -- Test for the Text_IO special unit case here, since we may be renaming
651 -- one of the subpackages of Text_IO, then join common routine.
653 Check_Text_IO_Special_Unit
(Name
(N
));
655 Analyze_Generic_Renaming
(N
, E_Generic_Package
);
656 end Analyze_Generic_Package_Renaming
;
658 ----------------------------------------
659 -- Analyze_Generic_Procedure_Renaming --
660 ----------------------------------------
662 procedure Analyze_Generic_Procedure_Renaming
(N
: Node_Id
) is
664 Analyze_Generic_Renaming
(N
, E_Generic_Procedure
);
665 end Analyze_Generic_Procedure_Renaming
;
667 ------------------------------
668 -- Analyze_Generic_Renaming --
669 ------------------------------
671 procedure Analyze_Generic_Renaming
675 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
676 Inst
: Boolean := False;
680 if Name
(N
) = Error
then
684 Check_SPARK_05_Restriction
("generic renaming is not allowed", N
);
686 Generate_Definition
(New_P
);
688 if Current_Scope
/= Standard_Standard
then
689 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
692 if Nkind
(Name
(N
)) = N_Selected_Component
then
693 Check_Generic_Child_Unit
(Name
(N
), Inst
);
698 if not Is_Entity_Name
(Name
(N
)) then
699 Error_Msg_N
("expect entity name in renaming declaration", Name
(N
));
702 Old_P
:= Entity
(Name
(N
));
706 Set_Ekind
(New_P
, K
);
708 if Etype
(Old_P
) = Any_Type
then
711 elsif Ekind
(Old_P
) /= K
then
712 Error_Msg_N
("invalid generic unit name", Name
(N
));
715 if Present
(Renamed_Object
(Old_P
)) then
716 Set_Renamed_Object
(New_P
, Renamed_Object
(Old_P
));
718 Set_Renamed_Object
(New_P
, Old_P
);
721 -- The generic renaming declaration may become Ghost if it renames a
724 Mark_Ghost_Renaming
(N
, Old_P
);
726 Set_Is_Pure
(New_P
, Is_Pure
(Old_P
));
727 Set_Is_Preelaborated
(New_P
, Is_Preelaborated
(Old_P
));
729 Set_Etype
(New_P
, Etype
(Old_P
));
730 Set_Has_Completion
(New_P
);
732 if In_Open_Scopes
(Old_P
) then
733 Error_Msg_N
("within its scope, generic denotes its instance", N
);
736 -- For subprograms, propagate the Intrinsic flag, to allow, e.g.
737 -- renamings and subsequent instantiations of Unchecked_Conversion.
739 if Ekind_In
(Old_P
, E_Generic_Function
, E_Generic_Procedure
) then
740 Set_Is_Intrinsic_Subprogram
741 (New_P
, Is_Intrinsic_Subprogram
(Old_P
));
744 Check_Library_Unit_Renaming
(N
, Old_P
);
747 -- Implementation-defined aspect specifications can appear in a renaming
748 -- declaration, but not language-defined ones. The call to procedure
749 -- Analyze_Aspect_Specifications will take care of this error check.
751 if Has_Aspects
(N
) then
752 Analyze_Aspect_Specifications
(N
, New_P
);
754 end Analyze_Generic_Renaming
;
756 -----------------------------
757 -- Analyze_Object_Renaming --
758 -----------------------------
760 procedure Analyze_Object_Renaming
(N
: Node_Id
) is
761 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
762 Loc
: constant Source_Ptr
:= Sloc
(N
);
763 Nam
: constant Node_Id
:= Name
(N
);
768 procedure Check_Constrained_Object
;
769 -- If the nominal type is unconstrained but the renamed object is
770 -- constrained, as can happen with renaming an explicit dereference or
771 -- a function return, build a constrained subtype from the object. If
772 -- the renaming is for a formal in an accept statement, the analysis
773 -- has already established its actual subtype. This is only relevant
774 -- if the renamed object is an explicit dereference.
776 ------------------------------
777 -- Check_Constrained_Object --
778 ------------------------------
780 procedure Check_Constrained_Object
is
781 Typ
: constant Entity_Id
:= Etype
(Nam
);
785 if Nkind_In
(Nam
, N_Function_Call
, N_Explicit_Dereference
)
786 and then Is_Composite_Type
(Etype
(Nam
))
787 and then not Is_Constrained
(Etype
(Nam
))
788 and then not Has_Unknown_Discriminants
(Etype
(Nam
))
789 and then Expander_Active
791 -- If Actual_Subtype is already set, nothing to do
793 if Ekind_In
(Id
, E_Variable
, E_Constant
)
794 and then Present
(Actual_Subtype
(Id
))
798 -- A renaming of an unchecked union has no actual subtype
800 elsif Is_Unchecked_Union
(Typ
) then
803 -- If a record is limited its size is invariant. This is the case
804 -- in particular with record types with an access discirminant
805 -- that are used in iterators. This is an optimization, but it
806 -- also prevents typing anomalies when the prefix is further
807 -- expanded. Limited types with discriminants are included.
809 elsif Is_Limited_Record
(Typ
)
811 (Ekind
(Typ
) = E_Limited_Private_Type
812 and then Has_Discriminants
(Typ
)
813 and then Is_Access_Type
(Etype
(First_Discriminant
(Typ
))))
818 Subt
:= Make_Temporary
(Loc
, 'T');
819 Remove_Side_Effects
(Nam
);
821 Make_Subtype_Declaration
(Loc
,
822 Defining_Identifier
=> Subt
,
823 Subtype_Indication
=>
824 Make_Subtype_From_Expr
(Nam
, Typ
)));
825 Rewrite
(Subtype_Mark
(N
), New_Occurrence_Of
(Subt
, Loc
));
826 Set_Etype
(Nam
, Subt
);
828 -- Freeze subtype at once, to prevent order of elaboration
829 -- issues in the backend. The renamed object exists, so its
830 -- type is already frozen in any case.
832 Freeze_Before
(N
, Subt
);
835 end Check_Constrained_Object
;
837 -- Start of processing for Analyze_Object_Renaming
844 Check_SPARK_05_Restriction
("object renaming is not allowed", N
);
846 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
849 -- The renaming of a component that depends on a discriminant requires
850 -- an actual subtype, because in subsequent use of the object Gigi will
851 -- be unable to locate the actual bounds. This explicit step is required
852 -- when the renaming is generated in removing side effects of an
853 -- already-analyzed expression.
855 if Nkind
(Nam
) = N_Selected_Component
and then Analyzed
(Nam
) then
857 -- The object renaming declaration may become Ghost if it renames a
860 if Is_Entity_Name
(Nam
) then
861 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
865 Dec
:= Build_Actual_Subtype_Of_Component
(Etype
(Nam
), Nam
);
867 if Present
(Dec
) then
868 Insert_Action
(N
, Dec
);
869 T
:= Defining_Identifier
(Dec
);
873 -- Complete analysis of the subtype mark in any case, for ASIS use
875 if Present
(Subtype_Mark
(N
)) then
876 Find_Type
(Subtype_Mark
(N
));
879 elsif Present
(Subtype_Mark
(N
)) then
880 Find_Type
(Subtype_Mark
(N
));
881 T
:= Entity
(Subtype_Mark
(N
));
884 -- The object renaming declaration may become Ghost if it renames a
887 if Is_Entity_Name
(Nam
) then
888 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
891 -- Reject renamings of conversions unless the type is tagged, or
892 -- the conversion is implicit (which can occur for cases of anonymous
893 -- access types in Ada 2012).
895 if Nkind
(Nam
) = N_Type_Conversion
896 and then Comes_From_Source
(Nam
)
897 and then not Is_Tagged_Type
(T
)
900 ("renaming of conversion only allowed for tagged types", Nam
);
905 -- If the renamed object is a function call of a limited type,
906 -- the expansion of the renaming is complicated by the presence
907 -- of various temporaries and subtypes that capture constraints
908 -- of the renamed object. Rewrite node as an object declaration,
909 -- whose expansion is simpler. Given that the object is limited
910 -- there is no copy involved and no performance hit.
912 if Nkind
(Nam
) = N_Function_Call
913 and then Is_Limited_View
(Etype
(Nam
))
914 and then not Is_Constrained
(Etype
(Nam
))
915 and then Comes_From_Source
(N
)
918 Set_Ekind
(Id
, E_Constant
);
920 Make_Object_Declaration
(Loc
,
921 Defining_Identifier
=> Id
,
922 Constant_Present
=> True,
923 Object_Definition
=> New_Occurrence_Of
(Etype
(Nam
), Loc
),
924 Expression
=> Relocate_Node
(Nam
)));
928 -- Ada 2012 (AI05-149): Reject renaming of an anonymous access object
929 -- when renaming declaration has a named access type. The Ada 2012
930 -- coverage rules allow an anonymous access type in the context of
931 -- an expected named general access type, but the renaming rules
932 -- require the types to be the same. (An exception is when the type
933 -- of the renaming is also an anonymous access type, which can only
934 -- happen due to a renaming created by the expander.)
936 if Nkind
(Nam
) = N_Type_Conversion
937 and then not Comes_From_Source
(Nam
)
938 and then Ekind
(Etype
(Expression
(Nam
))) = E_Anonymous_Access_Type
939 and then Ekind
(T
) /= E_Anonymous_Access_Type
941 Wrong_Type
(Expression
(Nam
), T
); -- Should we give better error???
944 -- Check that a class-wide object is not being renamed as an object
945 -- of a specific type. The test for access types is needed to exclude
946 -- cases where the renamed object is a dynamically tagged access
947 -- result, such as occurs in certain expansions.
949 if Is_Tagged_Type
(T
) then
950 Check_Dynamically_Tagged_Expression
956 -- Ada 2005 (AI-230/AI-254): Access renaming
958 else pragma Assert
(Present
(Access_Definition
(N
)));
962 N
=> Access_Definition
(N
));
966 -- The object renaming declaration may become Ghost if it renames a
969 if Is_Entity_Name
(Nam
) then
970 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
973 -- Ada 2005 AI05-105: if the declaration has an anonymous access
974 -- type, the renamed object must also have an anonymous type, and
975 -- this is a name resolution rule. This was implicit in the last part
976 -- of the first sentence in 8.5.1(3/2), and is made explicit by this
979 if not Is_Overloaded
(Nam
) then
980 if Ekind
(Etype
(Nam
)) /= Ekind
(T
) then
982 ("expect anonymous access type in object renaming", N
);
989 Typ
: Entity_Id
:= Empty
;
990 Seen
: Boolean := False;
993 Get_First_Interp
(Nam
, I
, It
);
994 while Present
(It
.Typ
) loop
996 -- Renaming is ambiguous if more than one candidate
997 -- interpretation is type-conformant with the context.
999 if Ekind
(It
.Typ
) = Ekind
(T
) then
1000 if Ekind
(T
) = E_Anonymous_Access_Subprogram_Type
1003 (Designated_Type
(T
), Designated_Type
(It
.Typ
))
1009 ("ambiguous expression in renaming", Nam
);
1012 elsif Ekind
(T
) = E_Anonymous_Access_Type
1014 Covers
(Designated_Type
(T
), Designated_Type
(It
.Typ
))
1020 ("ambiguous expression in renaming", Nam
);
1024 if Covers
(T
, It
.Typ
) then
1026 Set_Etype
(Nam
, Typ
);
1027 Set_Is_Overloaded
(Nam
, False);
1031 Get_Next_Interp
(I
, It
);
1038 -- Do not perform the legality checks below when the resolution of
1039 -- the renaming name failed because the associated type is Any_Type.
1041 if Etype
(Nam
) = Any_Type
then
1044 -- Ada 2005 (AI-231): In the case where the type is defined by an
1045 -- access_definition, the renamed entity shall be of an access-to-
1046 -- constant type if and only if the access_definition defines an
1047 -- access-to-constant type. ARM 8.5.1(4)
1049 elsif Constant_Present
(Access_Definition
(N
))
1050 and then not Is_Access_Constant
(Etype
(Nam
))
1053 ("(Ada 2005): the renamed object is not access-to-constant "
1054 & "(RM 8.5.1(6))", N
);
1056 elsif not Constant_Present
(Access_Definition
(N
))
1057 and then Is_Access_Constant
(Etype
(Nam
))
1060 ("(Ada 2005): the renamed object is not access-to-variable "
1061 & "(RM 8.5.1(6))", N
);
1064 if Is_Access_Subprogram_Type
(Etype
(Nam
)) then
1065 Check_Subtype_Conformant
1066 (Designated_Type
(T
), Designated_Type
(Etype
(Nam
)));
1068 elsif not Subtypes_Statically_Match
1069 (Designated_Type
(T
),
1070 Available_View
(Designated_Type
(Etype
(Nam
))))
1073 ("subtype of renamed object does not statically match", N
);
1077 -- Special processing for renaming function return object. Some errors
1078 -- and warnings are produced only for calls that come from source.
1080 if Nkind
(Nam
) = N_Function_Call
then
1083 -- Usage is illegal in Ada 83, but renamings are also introduced
1084 -- during expansion, and error does not apply to those.
1087 if Comes_From_Source
(N
) then
1089 ("(Ada 83) cannot rename function return object", Nam
);
1092 -- In Ada 95, warn for odd case of renaming parameterless function
1093 -- call if this is not a limited type (where this is useful).
1096 if Warn_On_Object_Renames_Function
1097 and then No
(Parameter_Associations
(Nam
))
1098 and then not Is_Limited_Type
(Etype
(Nam
))
1099 and then Comes_From_Source
(Nam
)
1102 ("renaming function result object is suspicious?R?", Nam
);
1104 ("\function & will be called only once?R?", Nam
,
1105 Entity
(Name
(Nam
)));
1106 Error_Msg_N
-- CODEFIX
1107 ("\suggest using an initialized constant object "
1108 & "instead?R?", Nam
);
1113 Check_Constrained_Object
;
1115 -- An object renaming requires an exact match of the type. Class-wide
1116 -- matching is not allowed.
1118 if Is_Class_Wide_Type
(T
)
1119 and then Base_Type
(Etype
(Nam
)) /= Base_Type
(T
)
1121 Wrong_Type
(Nam
, T
);
1126 -- Ada 2005 (AI-326): Handle wrong use of incomplete type
1128 if Nkind
(Nam
) = N_Explicit_Dereference
1129 and then Ekind
(Etype
(T2
)) = E_Incomplete_Type
1131 Error_Msg_NE
("invalid use of incomplete type&", Id
, T2
);
1134 elsif Ekind
(Etype
(T
)) = E_Incomplete_Type
then
1135 Error_Msg_NE
("invalid use of incomplete type&", Id
, T
);
1139 -- Ada 2005 (AI-327)
1141 if Ada_Version
>= Ada_2005
1142 and then Nkind
(Nam
) = N_Attribute_Reference
1143 and then Attribute_Name
(Nam
) = Name_Priority
1147 elsif Ada_Version
>= Ada_2005
and then Nkind
(Nam
) in N_Has_Entity
then
1150 Nam_Ent
: Entity_Id
;
1153 if Nkind
(Nam
) = N_Attribute_Reference
then
1154 Nam_Ent
:= Entity
(Prefix
(Nam
));
1156 Nam_Ent
:= Entity
(Nam
);
1159 Nam_Decl
:= Parent
(Nam_Ent
);
1161 if Has_Null_Exclusion
(N
)
1162 and then not Has_Null_Exclusion
(Nam_Decl
)
1164 -- Ada 2005 (AI-423): If the object name denotes a generic
1165 -- formal object of a generic unit G, and the object renaming
1166 -- declaration occurs within the body of G or within the body
1167 -- of a generic unit declared within the declarative region
1168 -- of G, then the declaration of the formal object of G must
1169 -- have a null exclusion or a null-excluding subtype.
1171 if Is_Formal_Object
(Nam_Ent
)
1172 and then In_Generic_Scope
(Id
)
1174 if not Can_Never_Be_Null
(Etype
(Nam_Ent
)) then
1176 ("renamed formal does not exclude `NULL` "
1177 & "(RM 8.5.1(4.6/2))", N
);
1179 elsif In_Package_Body
(Scope
(Id
)) then
1181 ("formal object does not have a null exclusion"
1182 & "(RM 8.5.1(4.6/2))", N
);
1185 -- Ada 2005 (AI-423): Otherwise, the subtype of the object name
1186 -- shall exclude null.
1188 elsif not Can_Never_Be_Null
(Etype
(Nam_Ent
)) then
1190 ("renamed object does not exclude `NULL` "
1191 & "(RM 8.5.1(4.6/2))", N
);
1193 -- An instance is illegal if it contains a renaming that
1194 -- excludes null, and the actual does not. The renaming
1195 -- declaration has already indicated that the declaration
1196 -- of the renamed actual in the instance will raise
1197 -- constraint_error.
1199 elsif Nkind
(Nam_Decl
) = N_Object_Declaration
1200 and then In_Instance
1202 Present
(Corresponding_Generic_Association
(Nam_Decl
))
1203 and then Nkind
(Expression
(Nam_Decl
)) =
1204 N_Raise_Constraint_Error
1207 ("renamed actual does not exclude `NULL` "
1208 & "(RM 8.5.1(4.6/2))", N
);
1210 -- Finally, if there is a null exclusion, the subtype mark
1211 -- must not be null-excluding.
1213 elsif No
(Access_Definition
(N
))
1214 and then Can_Never_Be_Null
(T
)
1217 ("`NOT NULL` not allowed (& already excludes null)",
1222 elsif Can_Never_Be_Null
(T
)
1223 and then not Can_Never_Be_Null
(Etype
(Nam_Ent
))
1226 ("renamed object does not exclude `NULL` "
1227 & "(RM 8.5.1(4.6/2))", N
);
1229 elsif Has_Null_Exclusion
(N
)
1230 and then No
(Access_Definition
(N
))
1231 and then Can_Never_Be_Null
(T
)
1234 ("`NOT NULL` not allowed (& already excludes null)", N
, T
);
1239 -- Set the Ekind of the entity, unless it has been set already, as is
1240 -- the case for the iteration object over a container with no variable
1241 -- indexing. In that case it's been marked as a constant, and we do not
1242 -- want to change it to a variable.
1244 if Ekind
(Id
) /= E_Constant
then
1245 Set_Ekind
(Id
, E_Variable
);
1248 -- Initialize the object size and alignment. Note that we used to call
1249 -- Init_Size_Align here, but that's wrong for objects which have only
1250 -- an Esize, not an RM_Size field.
1252 Init_Object_Size_Align
(Id
);
1254 if T
= Any_Type
or else Etype
(Nam
) = Any_Type
then
1257 -- Verify that the renamed entity is an object or a function call. It
1258 -- may have been rewritten in several ways.
1260 elsif Is_Object_Reference
(Nam
) then
1261 if Comes_From_Source
(N
) then
1262 if Is_Dependent_Component_Of_Mutable_Object
(Nam
) then
1264 ("illegal renaming of discriminant-dependent component", Nam
);
1267 -- If the renaming comes from source and the renamed object is a
1268 -- dereference, then mark the prefix as needing debug information,
1269 -- since it might have been rewritten hence internally generated
1270 -- and Debug_Renaming_Declaration will link the renaming to it.
1272 if Nkind
(Nam
) = N_Explicit_Dereference
1273 and then Is_Entity_Name
(Prefix
(Nam
))
1275 Set_Debug_Info_Needed
(Entity
(Prefix
(Nam
)));
1279 -- A static function call may have been folded into a literal
1281 elsif Nkind
(Original_Node
(Nam
)) = N_Function_Call
1283 -- When expansion is disabled, attribute reference is not rewritten
1284 -- as function call. Otherwise it may be rewritten as a conversion,
1285 -- so check original node.
1287 or else (Nkind
(Original_Node
(Nam
)) = N_Attribute_Reference
1288 and then Is_Function_Attribute_Name
1289 (Attribute_Name
(Original_Node
(Nam
))))
1291 -- Weird but legal, equivalent to renaming a function call. Illegal
1292 -- if the literal is the result of constant-folding an attribute
1293 -- reference that is not a function.
1295 or else (Is_Entity_Name
(Nam
)
1296 and then Ekind
(Entity
(Nam
)) = E_Enumeration_Literal
1298 Nkind
(Original_Node
(Nam
)) /= N_Attribute_Reference
)
1300 or else (Nkind
(Nam
) = N_Type_Conversion
1301 and then Is_Tagged_Type
(Entity
(Subtype_Mark
(Nam
))))
1305 elsif Nkind
(Nam
) = N_Type_Conversion
then
1307 ("renaming of conversion only allowed for tagged types", Nam
);
1309 -- Ada 2005 (AI-327)
1311 elsif Ada_Version
>= Ada_2005
1312 and then Nkind
(Nam
) = N_Attribute_Reference
1313 and then Attribute_Name
(Nam
) = Name_Priority
1317 -- Allow internally generated x'Ref resulting in N_Reference node
1319 elsif Nkind
(Nam
) = N_Reference
then
1323 Error_Msg_N
("expect object name in renaming", Nam
);
1328 if not Is_Variable
(Nam
) then
1329 Set_Ekind
(Id
, E_Constant
);
1330 Set_Never_Set_In_Source
(Id
, True);
1331 Set_Is_True_Constant
(Id
, True);
1334 -- The entity of the renaming declaration needs to reflect whether the
1335 -- renamed object is volatile. Is_Volatile is set if the renamed object
1336 -- is volatile in the RM legality sense.
1338 Set_Is_Volatile
(Id
, Is_Volatile_Object
(Nam
));
1340 -- Also copy settings of Atomic/Independent/Volatile_Full_Access
1342 if Is_Entity_Name
(Nam
) then
1343 Set_Is_Atomic
(Id
, Is_Atomic
(Entity
(Nam
)));
1344 Set_Is_Independent
(Id
, Is_Independent
(Entity
(Nam
)));
1345 Set_Is_Volatile_Full_Access
(Id
,
1346 Is_Volatile_Full_Access
(Entity
(Nam
)));
1349 -- Treat as volatile if we just set the Volatile flag
1353 -- Or if we are renaming an entity which was marked this way
1355 -- Are there more cases, e.g. X(J) where X is Treat_As_Volatile ???
1357 or else (Is_Entity_Name
(Nam
)
1358 and then Treat_As_Volatile
(Entity
(Nam
)))
1360 Set_Treat_As_Volatile
(Id
, True);
1363 -- Now make the link to the renamed object
1365 Set_Renamed_Object
(Id
, Nam
);
1367 -- Implementation-defined aspect specifications can appear in a renaming
1368 -- declaration, but not language-defined ones. The call to procedure
1369 -- Analyze_Aspect_Specifications will take care of this error check.
1371 if Has_Aspects
(N
) then
1372 Analyze_Aspect_Specifications
(N
, Id
);
1375 -- Deal with dimensions
1377 Analyze_Dimension
(N
);
1378 end Analyze_Object_Renaming
;
1380 ------------------------------
1381 -- Analyze_Package_Renaming --
1382 ------------------------------
1384 procedure Analyze_Package_Renaming
(N
: Node_Id
) is
1385 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
1390 if Name
(N
) = Error
then
1394 -- Check for Text_IO special unit (we may be renaming a Text_IO child)
1396 Check_Text_IO_Special_Unit
(Name
(N
));
1398 if Current_Scope
/= Standard_Standard
then
1399 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
1405 if Is_Entity_Name
(Name
(N
)) then
1406 Old_P
:= Entity
(Name
(N
));
1411 if Etype
(Old_P
) = Any_Type
then
1412 Error_Msg_N
("expect package name in renaming", Name
(N
));
1414 elsif Ekind
(Old_P
) /= E_Package
1415 and then not (Ekind
(Old_P
) = E_Generic_Package
1416 and then In_Open_Scopes
(Old_P
))
1418 if Ekind
(Old_P
) = E_Generic_Package
then
1420 ("generic package cannot be renamed as a package", Name
(N
));
1422 Error_Msg_Sloc
:= Sloc
(Old_P
);
1424 ("expect package name in renaming, found& declared#",
1428 -- Set basic attributes to minimize cascaded errors
1430 Set_Ekind
(New_P
, E_Package
);
1431 Set_Etype
(New_P
, Standard_Void_Type
);
1433 -- Here for OK package renaming
1436 -- Entities in the old package are accessible through the renaming
1437 -- entity. The simplest implementation is to have both packages share
1440 Set_Ekind
(New_P
, E_Package
);
1441 Set_Etype
(New_P
, Standard_Void_Type
);
1443 if Present
(Renamed_Object
(Old_P
)) then
1444 Set_Renamed_Object
(New_P
, Renamed_Object
(Old_P
));
1446 Set_Renamed_Object
(New_P
, Old_P
);
1449 -- The package renaming declaration may become Ghost if it renames a
1452 Mark_Ghost_Renaming
(N
, Old_P
);
1454 Set_Has_Completion
(New_P
);
1455 Set_First_Entity
(New_P
, First_Entity
(Old_P
));
1456 Set_Last_Entity
(New_P
, Last_Entity
(Old_P
));
1457 Set_First_Private_Entity
(New_P
, First_Private_Entity
(Old_P
));
1458 Check_Library_Unit_Renaming
(N
, Old_P
);
1459 Generate_Reference
(Old_P
, Name
(N
));
1461 -- If the renaming is in the visible part of a package, then we set
1462 -- Renamed_In_Spec for the renamed package, to prevent giving
1463 -- warnings about no entities referenced. Such a warning would be
1464 -- overenthusiastic, since clients can see entities in the renamed
1465 -- package via the visible package renaming.
1468 Ent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
1470 if Ekind
(Ent
) = E_Package
1471 and then not In_Private_Part
(Ent
)
1472 and then In_Extended_Main_Source_Unit
(N
)
1473 and then Ekind
(Old_P
) = E_Package
1475 Set_Renamed_In_Spec
(Old_P
);
1479 -- If this is the renaming declaration of a package instantiation
1480 -- within itself, it is the declaration that ends the list of actuals
1481 -- for the instantiation. At this point, the subtypes that rename
1482 -- the actuals are flagged as generic, to avoid spurious ambiguities
1483 -- if the actuals for two distinct formals happen to coincide. If
1484 -- the actual is a private type, the subtype has a private completion
1485 -- that is flagged in the same fashion.
1487 -- Resolution is identical to what is was in the original generic.
1488 -- On exit from the generic instance, these are turned into regular
1489 -- subtypes again, so they are compatible with types in their class.
1491 if not Is_Generic_Instance
(Old_P
) then
1494 Spec
:= Specification
(Unit_Declaration_Node
(Old_P
));
1497 if Nkind
(Spec
) = N_Package_Specification
1498 and then Present
(Generic_Parent
(Spec
))
1499 and then Old_P
= Current_Scope
1500 and then Chars
(New_P
) = Chars
(Generic_Parent
(Spec
))
1506 E
:= First_Entity
(Old_P
);
1507 while Present
(E
) and then E
/= New_P
loop
1509 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
1511 Set_Is_Generic_Actual_Type
(E
);
1513 if Is_Private_Type
(E
)
1514 and then Present
(Full_View
(E
))
1516 Set_Is_Generic_Actual_Type
(Full_View
(E
));
1526 -- Implementation-defined aspect specifications can appear in a renaming
1527 -- declaration, but not language-defined ones. The call to procedure
1528 -- Analyze_Aspect_Specifications will take care of this error check.
1530 if Has_Aspects
(N
) then
1531 Analyze_Aspect_Specifications
(N
, New_P
);
1533 end Analyze_Package_Renaming
;
1535 -------------------------------
1536 -- Analyze_Renamed_Character --
1537 -------------------------------
1539 procedure Analyze_Renamed_Character
1544 C
: constant Node_Id
:= Name
(N
);
1547 if Ekind
(New_S
) = E_Function
then
1548 Resolve
(C
, Etype
(New_S
));
1551 Check_Frozen_Renaming
(N
, New_S
);
1555 Error_Msg_N
("character literal can only be renamed as function", N
);
1557 end Analyze_Renamed_Character
;
1559 ---------------------------------
1560 -- Analyze_Renamed_Dereference --
1561 ---------------------------------
1563 procedure Analyze_Renamed_Dereference
1568 Nam
: constant Node_Id
:= Name
(N
);
1569 P
: constant Node_Id
:= Prefix
(Nam
);
1575 if not Is_Overloaded
(P
) then
1576 if Ekind
(Etype
(Nam
)) /= E_Subprogram_Type
1577 or else not Type_Conformant
(Etype
(Nam
), New_S
)
1579 Error_Msg_N
("designated type does not match specification", P
);
1588 Get_First_Interp
(Nam
, Ind
, It
);
1590 while Present
(It
.Nam
) loop
1592 if Ekind
(It
.Nam
) = E_Subprogram_Type
1593 and then Type_Conformant
(It
.Nam
, New_S
)
1595 if Typ
/= Any_Id
then
1596 Error_Msg_N
("ambiguous renaming", P
);
1603 Get_Next_Interp
(Ind
, It
);
1606 if Typ
= Any_Type
then
1607 Error_Msg_N
("designated type does not match specification", P
);
1612 Check_Frozen_Renaming
(N
, New_S
);
1616 end Analyze_Renamed_Dereference
;
1618 ---------------------------
1619 -- Analyze_Renamed_Entry --
1620 ---------------------------
1622 procedure Analyze_Renamed_Entry
1627 Nam
: constant Node_Id
:= Name
(N
);
1628 Sel
: constant Node_Id
:= Selector_Name
(Nam
);
1629 Is_Actual
: constant Boolean := Present
(Corresponding_Formal_Spec
(N
));
1633 if Entity
(Sel
) = Any_Id
then
1635 -- Selector is undefined on prefix. Error emitted already
1637 Set_Has_Completion
(New_S
);
1641 -- Otherwise find renamed entity and build body of New_S as a call to it
1643 Old_S
:= Find_Renamed_Entity
(N
, Selector_Name
(Nam
), New_S
);
1645 if Old_S
= Any_Id
then
1646 Error_Msg_N
(" no subprogram or entry matches specification", N
);
1649 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1650 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1651 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1654 -- Only mode conformance required for a renaming_as_declaration
1656 Check_Mode_Conformant
(New_S
, Old_S
, N
);
1659 Inherit_Renamed_Profile
(New_S
, Old_S
);
1661 -- The prefix can be an arbitrary expression that yields a task or
1662 -- protected object, so it must be resolved.
1664 Resolve
(Prefix
(Nam
), Scope
(Old_S
));
1667 Set_Convention
(New_S
, Convention
(Old_S
));
1668 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1670 -- AI05-0225: If the renamed entity is a procedure or entry of a
1671 -- protected object, the target object must be a variable.
1673 if Ekind
(Scope
(Old_S
)) in Protected_Kind
1674 and then Ekind
(New_S
) = E_Procedure
1675 and then not Is_Variable
(Prefix
(Nam
))
1679 ("target object of protected operation used as actual for "
1680 & "formal procedure must be a variable", Nam
);
1683 ("target object of protected operation renamed as procedure, "
1684 & "must be a variable", Nam
);
1689 Check_Frozen_Renaming
(N
, New_S
);
1691 end Analyze_Renamed_Entry
;
1693 -----------------------------------
1694 -- Analyze_Renamed_Family_Member --
1695 -----------------------------------
1697 procedure Analyze_Renamed_Family_Member
1702 Nam
: constant Node_Id
:= Name
(N
);
1703 P
: constant Node_Id
:= Prefix
(Nam
);
1707 if (Is_Entity_Name
(P
) and then Ekind
(Entity
(P
)) = E_Entry_Family
)
1708 or else (Nkind
(P
) = N_Selected_Component
1709 and then Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
)
1711 if Is_Entity_Name
(P
) then
1712 Old_S
:= Entity
(P
);
1714 Old_S
:= Entity
(Selector_Name
(P
));
1717 if not Entity_Matches_Spec
(Old_S
, New_S
) then
1718 Error_Msg_N
("entry family does not match specification", N
);
1721 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1722 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1723 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1727 Error_Msg_N
("no entry family matches specification", N
);
1730 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1733 Check_Frozen_Renaming
(N
, New_S
);
1735 end Analyze_Renamed_Family_Member
;
1737 -----------------------------------------
1738 -- Analyze_Renamed_Primitive_Operation --
1739 -----------------------------------------
1741 procedure Analyze_Renamed_Primitive_Operation
1750 Ctyp
: Conformance_Type
) return Boolean;
1751 -- Verify that the signatures of the renamed entity and the new entity
1752 -- match. The first formal of the renamed entity is skipped because it
1753 -- is the target object in any subsequent call.
1761 Ctyp
: Conformance_Type
) return Boolean
1767 if Ekind
(Subp
) /= Ekind
(New_S
) then
1771 Old_F
:= Next_Formal
(First_Formal
(Subp
));
1772 New_F
:= First_Formal
(New_S
);
1773 while Present
(Old_F
) and then Present
(New_F
) loop
1774 if not Conforming_Types
(Etype
(Old_F
), Etype
(New_F
), Ctyp
) then
1778 if Ctyp
>= Mode_Conformant
1779 and then Ekind
(Old_F
) /= Ekind
(New_F
)
1784 Next_Formal
(New_F
);
1785 Next_Formal
(Old_F
);
1791 -- Start of processing for Analyze_Renamed_Primitive_Operation
1794 if not Is_Overloaded
(Selector_Name
(Name
(N
))) then
1795 Old_S
:= Entity
(Selector_Name
(Name
(N
)));
1797 if not Conforms
(Old_S
, Type_Conformant
) then
1802 -- Find the operation that matches the given signature
1810 Get_First_Interp
(Selector_Name
(Name
(N
)), Ind
, It
);
1812 while Present
(It
.Nam
) loop
1813 if Conforms
(It
.Nam
, Type_Conformant
) then
1817 Get_Next_Interp
(Ind
, It
);
1822 if Old_S
= Any_Id
then
1823 Error_Msg_N
(" no subprogram or entry matches specification", N
);
1827 if not Conforms
(Old_S
, Subtype_Conformant
) then
1828 Error_Msg_N
("subtype conformance error in renaming", N
);
1831 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1832 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1835 -- Only mode conformance required for a renaming_as_declaration
1837 if not Conforms
(Old_S
, Mode_Conformant
) then
1838 Error_Msg_N
("mode conformance error in renaming", N
);
1841 -- Enforce the rule given in (RM 6.3.1 (10.1/2)): a prefixed
1842 -- view of a subprogram is intrinsic, because the compiler has
1843 -- to generate a wrapper for any call to it. If the name in a
1844 -- subprogram renaming is a prefixed view, the entity is thus
1845 -- intrinsic, and 'Access cannot be applied to it.
1847 Set_Convention
(New_S
, Convention_Intrinsic
);
1850 -- Inherit_Renamed_Profile (New_S, Old_S);
1852 -- The prefix can be an arbitrary expression that yields an
1853 -- object, so it must be resolved.
1855 Resolve
(Prefix
(Name
(N
)));
1857 end Analyze_Renamed_Primitive_Operation
;
1859 ---------------------------------
1860 -- Analyze_Subprogram_Renaming --
1861 ---------------------------------
1863 procedure Analyze_Subprogram_Renaming
(N
: Node_Id
) is
1864 Formal_Spec
: constant Entity_Id
:= Corresponding_Formal_Spec
(N
);
1865 Is_Actual
: constant Boolean := Present
(Formal_Spec
);
1866 Nam
: constant Node_Id
:= Name
(N
);
1867 Save_AV
: constant Ada_Version_Type
:= Ada_Version
;
1868 Save_AVP
: constant Node_Id
:= Ada_Version_Pragma
;
1869 Save_AV_Exp
: constant Ada_Version_Type
:= Ada_Version_Explicit
;
1870 Spec
: constant Node_Id
:= Specification
(N
);
1872 Old_S
: Entity_Id
:= Empty
;
1873 Rename_Spec
: Entity_Id
;
1875 procedure Build_Class_Wide_Wrapper
1876 (Ren_Id
: out Entity_Id
;
1877 Wrap_Id
: out Entity_Id
);
1878 -- Ada 2012 (AI05-0071): A generic/instance scenario involving a formal
1879 -- type with unknown discriminants and a generic primitive operation of
1880 -- the said type with a box require special processing when the actual
1881 -- is a class-wide type:
1884 -- type Formal_Typ (<>) is private;
1885 -- with procedure Prim_Op (Param : Formal_Typ) is <>;
1886 -- package Gen is ...
1888 -- package Inst is new Gen (Actual_Typ'Class);
1890 -- In this case the general renaming mechanism used in the prologue of
1891 -- an instance no longer applies:
1893 -- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op;
1895 -- The above is replaced the following wrapper/renaming combination:
1897 -- procedure Wrapper (Param : Formal_Typ) is -- wrapper
1899 -- Prim_Op (Param); -- primitive
1902 -- procedure Prim_Op (Param : Formal_Typ) renames Wrapper;
1904 -- This transformation applies only if there is no explicit visible
1905 -- class-wide operation at the point of the instantiation. Ren_Id is
1906 -- the entity of the renaming declaration. When the transformation
1907 -- applies, Wrap_Id is the entity of the generated class-wide wrapper
1908 -- (or Any_Id). Otherwise, Wrap_Id is the entity of the class-wide
1911 procedure Check_Null_Exclusion
1914 -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the
1915 -- following AI rules:
1917 -- If Ren is a renaming of a formal subprogram and one of its
1918 -- parameters has a null exclusion, then the corresponding formal
1919 -- in Sub must also have one. Otherwise the subtype of the Sub's
1920 -- formal parameter must exclude null.
1922 -- If Ren is a renaming of a formal function and its return
1923 -- profile has a null exclusion, then Sub's return profile must
1924 -- have one. Otherwise the subtype of Sub's return profile must
1927 procedure Freeze_Actual_Profile
;
1928 -- In Ada 2012, enforce the freezing rule concerning formal incomplete
1929 -- types: a callable entity freezes its profile, unless it has an
1930 -- incomplete untagged formal (RM 13.14(10.2/3)).
1932 function Has_Class_Wide_Actual
return Boolean;
1933 -- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a
1934 -- defaulted formal subprogram where the actual for the controlling
1935 -- formal type is class-wide.
1937 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
;
1938 -- Find renamed entity when the declaration is a renaming_as_body and
1939 -- the renamed entity may itself be a renaming_as_body. Used to enforce
1940 -- rule that a renaming_as_body is illegal if the declaration occurs
1941 -- before the subprogram it completes is frozen, and renaming indirectly
1942 -- renames the subprogram itself.(Defect Report 8652/0027).
1944 ------------------------------
1945 -- Build_Class_Wide_Wrapper --
1946 ------------------------------
1948 procedure Build_Class_Wide_Wrapper
1949 (Ren_Id
: out Entity_Id
;
1950 Wrap_Id
: out Entity_Id
)
1952 Loc
: constant Source_Ptr
:= Sloc
(N
);
1955 (Subp_Id
: Entity_Id
;
1956 Params
: List_Id
) return Node_Id
;
1957 -- Create a dispatching call to invoke routine Subp_Id with actuals
1958 -- built from the parameter specifications of list Params.
1960 function Build_Expr_Fun_Call
1961 (Subp_Id
: Entity_Id
;
1962 Params
: List_Id
) return Node_Id
;
1963 -- Create a dispatching call to invoke function Subp_Id with actuals
1964 -- built from the parameter specifications of list Params. Return
1965 -- directly the call, so that it can be used inside an expression
1966 -- function. This is a specificity of the GNATprove mode.
1968 function Build_Spec
(Subp_Id
: Entity_Id
) return Node_Id
;
1969 -- Create a subprogram specification based on the subprogram profile
1972 function Find_Primitive
(Typ
: Entity_Id
) return Entity_Id
;
1973 -- Find a primitive subprogram of type Typ which matches the profile
1974 -- of the renaming declaration.
1976 procedure Interpretation_Error
(Subp_Id
: Entity_Id
);
1977 -- Emit a continuation error message suggesting subprogram Subp_Id as
1978 -- a possible interpretation.
1980 function Is_Intrinsic_Equality
(Subp_Id
: Entity_Id
) return Boolean;
1981 -- Determine whether subprogram Subp_Id denotes the intrinsic "="
1984 function Is_Suitable_Candidate
(Subp_Id
: Entity_Id
) return Boolean;
1985 -- Determine whether subprogram Subp_Id is a suitable candidate for
1986 -- the role of a wrapped subprogram.
1993 (Subp_Id
: Entity_Id
;
1994 Params
: List_Id
) return Node_Id
1996 Actuals
: constant List_Id
:= New_List
;
1997 Call_Ref
: constant Node_Id
:= New_Occurrence_Of
(Subp_Id
, Loc
);
2001 -- Build the actual parameters of the call
2003 Formal
:= First
(Params
);
2004 while Present
(Formal
) loop
2006 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
2011 -- return Subp_Id (Actuals);
2013 if Ekind_In
(Subp_Id
, E_Function
, E_Operator
) then
2015 Make_Simple_Return_Statement
(Loc
,
2017 Make_Function_Call
(Loc
,
2019 Parameter_Associations
=> Actuals
));
2022 -- Subp_Id (Actuals);
2026 Make_Procedure_Call_Statement
(Loc
,
2028 Parameter_Associations
=> Actuals
);
2032 -------------------------
2033 -- Build_Expr_Fun_Call --
2034 -------------------------
2036 function Build_Expr_Fun_Call
2037 (Subp_Id
: Entity_Id
;
2038 Params
: List_Id
) return Node_Id
2040 Actuals
: constant List_Id
:= New_List
;
2041 Call_Ref
: constant Node_Id
:= New_Occurrence_Of
(Subp_Id
, Loc
);
2045 pragma Assert
(Ekind_In
(Subp_Id
, E_Function
, E_Operator
));
2047 -- Build the actual parameters of the call
2049 Formal
:= First
(Params
);
2050 while Present
(Formal
) loop
2052 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
2057 -- Subp_Id (Actuals);
2060 Make_Function_Call
(Loc
,
2062 Parameter_Associations
=> Actuals
);
2063 end Build_Expr_Fun_Call
;
2069 function Build_Spec
(Subp_Id
: Entity_Id
) return Node_Id
is
2070 Params
: constant List_Id
:= Copy_Parameter_List
(Subp_Id
);
2071 Spec_Id
: constant Entity_Id
:=
2072 Make_Defining_Identifier
(Loc
,
2073 Chars
=> New_External_Name
(Chars
(Subp_Id
), 'R'));
2076 if Ekind
(Formal_Spec
) = E_Procedure
then
2078 Make_Procedure_Specification
(Loc
,
2079 Defining_Unit_Name
=> Spec_Id
,
2080 Parameter_Specifications
=> Params
);
2083 Make_Function_Specification
(Loc
,
2084 Defining_Unit_Name
=> Spec_Id
,
2085 Parameter_Specifications
=> Params
,
2086 Result_Definition
=>
2087 New_Copy_Tree
(Result_Definition
(Spec
)));
2091 --------------------
2092 -- Find_Primitive --
2093 --------------------
2095 function Find_Primitive
(Typ
: Entity_Id
) return Entity_Id
is
2096 procedure Replace_Parameter_Types
(Spec
: Node_Id
);
2097 -- Given a specification Spec, replace all class-wide parameter
2098 -- types with reference to type Typ.
2100 -----------------------------
2101 -- Replace_Parameter_Types --
2102 -----------------------------
2104 procedure Replace_Parameter_Types
(Spec
: Node_Id
) is
2106 Formal_Id
: Entity_Id
;
2107 Formal_Typ
: Node_Id
;
2110 Formal
:= First
(Parameter_Specifications
(Spec
));
2111 while Present
(Formal
) loop
2112 Formal_Id
:= Defining_Identifier
(Formal
);
2113 Formal_Typ
:= Parameter_Type
(Formal
);
2115 -- Create a new entity for each class-wide formal to prevent
2116 -- aliasing with the original renaming. Replace the type of
2117 -- such a parameter with the candidate type.
2119 if Nkind
(Formal_Typ
) = N_Identifier
2120 and then Is_Class_Wide_Type
(Etype
(Formal_Typ
))
2122 Set_Defining_Identifier
(Formal
,
2123 Make_Defining_Identifier
(Loc
, Chars
(Formal_Id
)));
2125 Set_Parameter_Type
(Formal
, New_Occurrence_Of
(Typ
, Loc
));
2130 end Replace_Parameter_Types
;
2134 Alt_Ren
: constant Node_Id
:= New_Copy_Tree
(N
);
2135 Alt_Nam
: constant Node_Id
:= Name
(Alt_Ren
);
2136 Alt_Spec
: constant Node_Id
:= Specification
(Alt_Ren
);
2137 Subp_Id
: Entity_Id
;
2139 -- Start of processing for Find_Primitive
2142 -- Each attempt to find a suitable primitive of a particular type
2143 -- operates on its own copy of the original renaming. As a result
2144 -- the original renaming is kept decoration and side-effect free.
2146 -- Inherit the overloaded status of the renamed subprogram name
2148 if Is_Overloaded
(Nam
) then
2149 Set_Is_Overloaded
(Alt_Nam
);
2150 Save_Interps
(Nam
, Alt_Nam
);
2153 -- The copied renaming is hidden from visibility to prevent the
2154 -- pollution of the enclosing context.
2156 Set_Defining_Unit_Name
(Alt_Spec
, Make_Temporary
(Loc
, 'R'));
2158 -- The types of all class-wide parameters must be changed to the
2161 Replace_Parameter_Types
(Alt_Spec
);
2163 -- Try to find a suitable primitive which matches the altered
2164 -- profile of the renaming specification.
2169 Nam
=> Name
(Alt_Ren
),
2170 New_S
=> Analyze_Subprogram_Specification
(Alt_Spec
),
2171 Is_Actual
=> Is_Actual
);
2173 -- Do not return Any_Id if the resolion of the altered profile
2174 -- failed as this complicates further checks on the caller side,
2175 -- return Empty instead.
2177 if Subp_Id
= Any_Id
then
2184 --------------------------
2185 -- Interpretation_Error --
2186 --------------------------
2188 procedure Interpretation_Error
(Subp_Id
: Entity_Id
) is
2190 Error_Msg_Sloc
:= Sloc
(Subp_Id
);
2192 if Is_Internal
(Subp_Id
) then
2194 ("\\possible interpretation: predefined & #",
2198 ("\\possible interpretation: & defined #", Spec
, Formal_Spec
);
2200 end Interpretation_Error
;
2202 ---------------------------
2203 -- Is_Intrinsic_Equality --
2204 ---------------------------
2206 function Is_Intrinsic_Equality
(Subp_Id
: Entity_Id
) return Boolean is
2209 Ekind
(Subp_Id
) = E_Operator
2210 and then Chars
(Subp_Id
) = Name_Op_Eq
2211 and then Is_Intrinsic_Subprogram
(Subp_Id
);
2212 end Is_Intrinsic_Equality
;
2214 ---------------------------
2215 -- Is_Suitable_Candidate --
2216 ---------------------------
2218 function Is_Suitable_Candidate
(Subp_Id
: Entity_Id
) return Boolean is
2220 if No
(Subp_Id
) then
2223 -- An intrinsic subprogram is never a good candidate. This is an
2224 -- indication of a missing primitive, either defined directly or
2225 -- inherited from a parent tagged type.
2227 elsif Is_Intrinsic_Subprogram
(Subp_Id
) then
2233 end Is_Suitable_Candidate
;
2237 Actual_Typ
: Entity_Id
:= Empty
;
2238 -- The actual class-wide type for Formal_Typ
2240 CW_Prim_OK
: Boolean;
2241 CW_Prim_Op
: Entity_Id
;
2242 -- The class-wide subprogram (if available) which corresponds to the
2243 -- renamed generic formal subprogram.
2245 Formal_Typ
: Entity_Id
:= Empty
;
2246 -- The generic formal type with unknown discriminants
2248 Root_Prim_OK
: Boolean;
2249 Root_Prim_Op
: Entity_Id
;
2250 -- The root type primitive (if available) which corresponds to the
2251 -- renamed generic formal subprogram.
2253 Root_Typ
: Entity_Id
:= Empty
;
2254 -- The root type of Actual_Typ
2256 Body_Decl
: Node_Id
;
2258 Prim_Op
: Entity_Id
;
2259 Spec_Decl
: Node_Id
;
2262 -- Start of processing for Build_Class_Wide_Wrapper
2265 -- Analyze the specification of the renaming in case the generation
2266 -- of the class-wide wrapper fails.
2268 Ren_Id
:= Analyze_Subprogram_Specification
(Spec
);
2271 -- Do not attempt to build a wrapper if the renaming is in error
2273 if Error_Posted
(Nam
) then
2277 -- Analyze the renamed name, but do not resolve it. The resolution is
2278 -- completed once a suitable subprogram is found.
2282 -- When the renamed name denotes the intrinsic operator equals, the
2283 -- name must be treated as overloaded. This allows for a potential
2284 -- match against the root type's predefined equality function.
2286 if Is_Intrinsic_Equality
(Entity
(Nam
)) then
2287 Set_Is_Overloaded
(Nam
);
2288 Collect_Interps
(Nam
);
2291 -- Step 1: Find the generic formal type with unknown discriminants
2292 -- and its corresponding class-wide actual type from the renamed
2293 -- generic formal subprogram.
2295 Formal
:= First_Formal
(Formal_Spec
);
2296 while Present
(Formal
) loop
2297 if Has_Unknown_Discriminants
(Etype
(Formal
))
2298 and then not Is_Class_Wide_Type
(Etype
(Formal
))
2299 and then Is_Class_Wide_Type
(Get_Instance_Of
(Etype
(Formal
)))
2301 Formal_Typ
:= Etype
(Formal
);
2302 Actual_Typ
:= Get_Instance_Of
(Formal_Typ
);
2303 Root_Typ
:= Etype
(Actual_Typ
);
2307 Next_Formal
(Formal
);
2310 -- The specification of the generic formal subprogram should always
2311 -- contain a formal type with unknown discriminants whose actual is
2312 -- a class-wide type, otherwise this indicates a failure in routine
2313 -- Has_Class_Wide_Actual.
2315 pragma Assert
(Present
(Formal_Typ
));
2317 -- Step 2: Find the proper class-wide subprogram or primitive which
2318 -- corresponds to the renamed generic formal subprogram.
2320 CW_Prim_Op
:= Find_Primitive
(Actual_Typ
);
2321 CW_Prim_OK
:= Is_Suitable_Candidate
(CW_Prim_Op
);
2322 Root_Prim_Op
:= Find_Primitive
(Root_Typ
);
2323 Root_Prim_OK
:= Is_Suitable_Candidate
(Root_Prim_Op
);
2325 -- The class-wide actual type has two subprograms which correspond to
2326 -- the renamed generic formal subprogram:
2328 -- with procedure Prim_Op (Param : Formal_Typ);
2330 -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited
2331 -- procedure Prim_Op (Param : Actual_Typ'Class);
2333 -- Even though the declaration of the two subprograms is legal, a
2334 -- call to either one is ambiguous and therefore illegal.
2336 if CW_Prim_OK
and Root_Prim_OK
then
2338 -- A user-defined primitive has precedence over a predefined one
2340 if Is_Internal
(CW_Prim_Op
)
2341 and then not Is_Internal
(Root_Prim_Op
)
2343 Prim_Op
:= Root_Prim_Op
;
2345 elsif Is_Internal
(Root_Prim_Op
)
2346 and then not Is_Internal
(CW_Prim_Op
)
2348 Prim_Op
:= CW_Prim_Op
;
2350 elsif CW_Prim_Op
= Root_Prim_Op
then
2351 Prim_Op
:= Root_Prim_Op
;
2353 -- Otherwise both candidate subprograms are user-defined and
2358 ("ambiguous actual for generic subprogram &",
2360 Interpretation_Error
(Root_Prim_Op
);
2361 Interpretation_Error
(CW_Prim_Op
);
2365 elsif CW_Prim_OK
and not Root_Prim_OK
then
2366 Prim_Op
:= CW_Prim_Op
;
2368 elsif not CW_Prim_OK
and Root_Prim_OK
then
2369 Prim_Op
:= Root_Prim_Op
;
2371 -- An intrinsic equality may act as a suitable candidate in the case
2372 -- of a null type extension where the parent's equality is hidden. A
2373 -- call to an intrinsic equality is expanded as dispatching.
2375 elsif Present
(Root_Prim_Op
)
2376 and then Is_Intrinsic_Equality
(Root_Prim_Op
)
2378 Prim_Op
:= Root_Prim_Op
;
2380 -- Otherwise there are no candidate subprograms. Let the caller
2381 -- diagnose the error.
2387 -- At this point resolution has taken place and the name is no longer
2388 -- overloaded. Mark the primitive as referenced.
2390 Set_Is_Overloaded
(Name
(N
), False);
2391 Set_Referenced
(Prim_Op
);
2393 -- Do not generate a wrapper when the only candidate is a class-wide
2394 -- subprogram. Instead modify the renaming to directly map the actual
2395 -- to the generic formal.
2397 if CW_Prim_OK
and then Prim_Op
= CW_Prim_Op
then
2399 Rewrite
(Nam
, New_Occurrence_Of
(Prim_Op
, Loc
));
2403 -- Step 3: Create the declaration and the body of the wrapper, insert
2404 -- all the pieces into the tree.
2406 -- In GNATprove mode, create a function wrapper in the form of an
2407 -- expression function, so that an implicit postcondition relating
2408 -- the result of calling the wrapper function and the result of the
2409 -- dispatching call to the wrapped function is known during proof.
2412 and then Ekind_In
(Ren_Id
, E_Function
, E_Operator
)
2414 New_Spec
:= Build_Spec
(Ren_Id
);
2416 Make_Expression_Function
(Loc
,
2417 Specification
=> New_Spec
,
2420 (Subp_Id
=> Prim_Op
,
2421 Params
=> Parameter_Specifications
(New_Spec
)));
2423 Wrap_Id
:= Defining_Entity
(Body_Decl
);
2425 -- Otherwise, create separate spec and body for the subprogram
2429 Make_Subprogram_Declaration
(Loc
,
2430 Specification
=> Build_Spec
(Ren_Id
));
2431 Insert_Before_And_Analyze
(N
, Spec_Decl
);
2433 Wrap_Id
:= Defining_Entity
(Spec_Decl
);
2436 Make_Subprogram_Body
(Loc
,
2437 Specification
=> Build_Spec
(Ren_Id
),
2438 Declarations
=> New_List
,
2439 Handled_Statement_Sequence
=>
2440 Make_Handled_Sequence_Of_Statements
(Loc
,
2441 Statements
=> New_List
(
2443 (Subp_Id
=> Prim_Op
,
2445 Parameter_Specifications
2446 (Specification
(Spec_Decl
))))));
2448 Set_Corresponding_Body
(Spec_Decl
, Defining_Entity
(Body_Decl
));
2451 -- If the operator carries an Eliminated pragma, indicate that the
2452 -- wrapper is also to be eliminated, to prevent spurious error when
2453 -- using gnatelim on programs that include box-initialization of
2454 -- equality operators.
2456 Set_Is_Eliminated
(Wrap_Id
, Is_Eliminated
(Prim_Op
));
2458 -- In GNATprove mode, insert the body in the tree for analysis
2460 if GNATprove_Mode
then
2461 Insert_Before_And_Analyze
(N
, Body_Decl
);
2464 -- The generated body does not freeze and must be analyzed when the
2465 -- class-wide wrapper is frozen. The body is only needed if expansion
2468 if Expander_Active
then
2469 Append_Freeze_Action
(Wrap_Id
, Body_Decl
);
2472 -- Step 4: The subprogram renaming aliases the wrapper
2474 Rewrite
(Nam
, New_Occurrence_Of
(Wrap_Id
, Loc
));
2475 end Build_Class_Wide_Wrapper
;
2477 --------------------------
2478 -- Check_Null_Exclusion --
2479 --------------------------
2481 procedure Check_Null_Exclusion
2485 Ren_Formal
: Entity_Id
;
2486 Sub_Formal
: Entity_Id
;
2491 Ren_Formal
:= First_Formal
(Ren
);
2492 Sub_Formal
:= First_Formal
(Sub
);
2493 while Present
(Ren_Formal
) and then Present
(Sub_Formal
) loop
2494 if Has_Null_Exclusion
(Parent
(Ren_Formal
))
2496 not (Has_Null_Exclusion
(Parent
(Sub_Formal
))
2497 or else Can_Never_Be_Null
(Etype
(Sub_Formal
)))
2500 ("`NOT NULL` required for parameter &",
2501 Parent
(Sub_Formal
), Sub_Formal
);
2504 Next_Formal
(Ren_Formal
);
2505 Next_Formal
(Sub_Formal
);
2508 -- Return profile check
2510 if Nkind
(Parent
(Ren
)) = N_Function_Specification
2511 and then Nkind
(Parent
(Sub
)) = N_Function_Specification
2512 and then Has_Null_Exclusion
(Parent
(Ren
))
2513 and then not (Has_Null_Exclusion
(Parent
(Sub
))
2514 or else Can_Never_Be_Null
(Etype
(Sub
)))
2517 ("return must specify `NOT NULL`",
2518 Result_Definition
(Parent
(Sub
)));
2520 end Check_Null_Exclusion
;
2522 ---------------------------
2523 -- Freeze_Actual_Profile --
2524 ---------------------------
2526 procedure Freeze_Actual_Profile
is
2528 Has_Untagged_Inc
: Boolean;
2529 Instantiation_Node
: constant Node_Id
:= Parent
(N
);
2532 if Ada_Version
>= Ada_2012
then
2533 F
:= First_Formal
(Formal_Spec
);
2534 Has_Untagged_Inc
:= False;
2535 while Present
(F
) loop
2536 if Ekind
(Etype
(F
)) = E_Incomplete_Type
2537 and then not Is_Tagged_Type
(Etype
(F
))
2539 Has_Untagged_Inc
:= True;
2543 F
:= Next_Formal
(F
);
2546 if Ekind
(Formal_Spec
) = E_Function
2547 and then not Is_Tagged_Type
(Etype
(Formal_Spec
))
2549 Has_Untagged_Inc
:= True;
2552 if not Has_Untagged_Inc
then
2553 F
:= First_Formal
(Old_S
);
2554 while Present
(F
) loop
2555 Freeze_Before
(Instantiation_Node
, Etype
(F
));
2557 if Is_Incomplete_Or_Private_Type
(Etype
(F
))
2558 and then No
(Underlying_Type
(Etype
(F
)))
2560 -- Exclude generic types, or types derived from them.
2561 -- They will be frozen in the enclosing instance.
2563 if Is_Generic_Type
(Etype
(F
))
2564 or else Is_Generic_Type
(Root_Type
(Etype
(F
)))
2568 -- A limited view of a type declared elsewhere needs no
2569 -- freezing actions.
2571 elsif From_Limited_With
(Etype
(F
)) then
2576 ("type& must be frozen before this point",
2577 Instantiation_Node
, Etype
(F
));
2581 F
:= Next_Formal
(F
);
2585 end Freeze_Actual_Profile
;
2587 ---------------------------
2588 -- Has_Class_Wide_Actual --
2589 ---------------------------
2591 function Has_Class_Wide_Actual
return Boolean is
2593 Formal_Typ
: Entity_Id
;
2597 Formal
:= First_Formal
(Formal_Spec
);
2598 while Present
(Formal
) loop
2599 Formal_Typ
:= Etype
(Formal
);
2601 if Has_Unknown_Discriminants
(Formal_Typ
)
2602 and then not Is_Class_Wide_Type
(Formal_Typ
)
2603 and then Is_Class_Wide_Type
(Get_Instance_Of
(Formal_Typ
))
2608 Next_Formal
(Formal
);
2613 end Has_Class_Wide_Actual
;
2615 -------------------------
2616 -- Original_Subprogram --
2617 -------------------------
2619 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
is
2620 Orig_Decl
: Node_Id
;
2621 Orig_Subp
: Entity_Id
;
2624 -- First case: renamed entity is itself a renaming
2626 if Present
(Alias
(Subp
)) then
2627 return Alias
(Subp
);
2629 elsif Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
2630 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(Subp
)))
2632 -- Check if renamed entity is a renaming_as_body
2635 Unit_Declaration_Node
2636 (Corresponding_Body
(Unit_Declaration_Node
(Subp
)));
2638 if Nkind
(Orig_Decl
) = N_Subprogram_Renaming_Declaration
then
2639 Orig_Subp
:= Entity
(Name
(Orig_Decl
));
2641 if Orig_Subp
= Rename_Spec
then
2643 -- Circularity detected
2648 return (Original_Subprogram
(Orig_Subp
));
2656 end Original_Subprogram
;
2660 CW_Actual
: constant Boolean := Has_Class_Wide_Actual
;
2661 -- Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a
2662 -- defaulted formal subprogram when the actual for a related formal
2663 -- type is class-wide.
2665 Inst_Node
: Node_Id
:= Empty
;
2668 -- Start of processing for Analyze_Subprogram_Renaming
2671 -- We must test for the attribute renaming case before the Analyze
2672 -- call because otherwise Sem_Attr will complain that the attribute
2673 -- is missing an argument when it is analyzed.
2675 if Nkind
(Nam
) = N_Attribute_Reference
then
2677 -- In the case of an abstract formal subprogram association, rewrite
2678 -- an actual given by a stream attribute as the name of the
2679 -- corresponding stream primitive of the type.
2681 -- In a generic context the stream operations are not generated, and
2682 -- this must be treated as a normal attribute reference, to be
2683 -- expanded in subsequent instantiations.
2686 and then Is_Abstract_Subprogram
(Formal_Spec
)
2687 and then Expander_Active
2690 Prefix_Type
: constant Entity_Id
:= Entity
(Prefix
(Nam
));
2691 Stream_Prim
: Entity_Id
;
2694 -- The class-wide forms of the stream attributes are not
2695 -- primitive dispatching operations (even though they
2696 -- internally dispatch to a stream attribute).
2698 if Is_Class_Wide_Type
(Prefix_Type
) then
2700 ("attribute must be a primitive dispatching operation",
2705 -- Retrieve the primitive subprogram associated with the
2706 -- attribute. This can only be a stream attribute, since those
2707 -- are the only ones that are dispatching (and the actual for
2708 -- an abstract formal subprogram must be dispatching
2711 case Attribute_Name
(Nam
) is
2714 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Input
);
2718 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Output
);
2722 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Read
);
2726 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Write
);
2730 ("attribute must be a primitive dispatching operation",
2735 -- If no operation was found, and the type is limited, the user
2736 -- should have defined one.
2738 if No
(Stream_Prim
) then
2739 if Is_Limited_Type
(Prefix_Type
) then
2741 ("stream operation not defined for type&",
2745 -- Otherwise, compiler should have generated default
2748 raise Program_Error
;
2752 -- Rewrite the attribute into the name of its corresponding
2753 -- primitive dispatching subprogram. We can then proceed with
2754 -- the usual processing for subprogram renamings.
2757 Prim_Name
: constant Node_Id
:=
2758 Make_Identifier
(Sloc
(Nam
),
2759 Chars
=> Chars
(Stream_Prim
));
2761 Set_Entity
(Prim_Name
, Stream_Prim
);
2762 Rewrite
(Nam
, Prim_Name
);
2767 -- Normal processing for a renaming of an attribute
2770 Attribute_Renaming
(N
);
2775 -- Check whether this declaration corresponds to the instantiation of a
2776 -- formal subprogram.
2778 -- If this is an instantiation, the corresponding actual is frozen and
2779 -- error messages can be made more precise. If this is a default
2780 -- subprogram, the entity is already established in the generic, and is
2781 -- not retrieved by visibility. If it is a default with a box, the
2782 -- candidate interpretations, if any, have been collected when building
2783 -- the renaming declaration. If overloaded, the proper interpretation is
2784 -- determined in Find_Renamed_Entity. If the entity is an operator,
2785 -- Find_Renamed_Entity applies additional visibility checks.
2788 Inst_Node
:= Unit_Declaration_Node
(Formal_Spec
);
2790 -- Check whether the renaming is for a defaulted actual subprogram
2791 -- with a class-wide actual.
2793 -- The class-wide wrapper is not needed in GNATprove_Mode and there
2794 -- is an external axiomatization on the package.
2797 and then Box_Present
(Inst_Node
)
2801 Present
(Containing_Package_With_Ext_Axioms
(Formal_Spec
)))
2803 Build_Class_Wide_Wrapper
(New_S
, Old_S
);
2805 elsif Is_Entity_Name
(Nam
)
2806 and then Present
(Entity
(Nam
))
2807 and then not Comes_From_Source
(Nam
)
2808 and then not Is_Overloaded
(Nam
)
2810 Old_S
:= Entity
(Nam
);
2812 -- The subprogram renaming declaration may become Ghost if it
2813 -- renames a Ghost entity.
2815 Mark_Ghost_Renaming
(N
, Old_S
);
2817 New_S
:= Analyze_Subprogram_Specification
(Spec
);
2821 if Ekind
(Old_S
) = E_Operator
then
2825 if Box_Present
(Inst_Node
) then
2826 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
2828 -- If there is an immediately visible homonym of the operator
2829 -- and the declaration has a default, this is worth a warning
2830 -- because the user probably did not intend to get the pre-
2831 -- defined operator, visible in the generic declaration. To
2832 -- find if there is an intended candidate, analyze the renaming
2833 -- again in the current context.
2835 elsif Scope
(Old_S
) = Standard_Standard
2836 and then Present
(Default_Name
(Inst_Node
))
2839 Decl
: constant Node_Id
:= New_Copy_Tree
(N
);
2843 Set_Entity
(Name
(Decl
), Empty
);
2844 Analyze
(Name
(Decl
));
2846 Find_Renamed_Entity
(Decl
, Name
(Decl
), New_S
, True);
2849 and then In_Open_Scopes
(Scope
(Hidden
))
2850 and then Is_Immediately_Visible
(Hidden
)
2851 and then Comes_From_Source
(Hidden
)
2852 and then Hidden
/= Old_S
2854 Error_Msg_Sloc
:= Sloc
(Hidden
);
2856 ("default subprogram is resolved in the generic "
2857 & "declaration (RM 12.6(17))??", N
);
2858 Error_Msg_NE
("\and will not use & #??", N
, Hidden
);
2867 -- The subprogram renaming declaration may become Ghost if it
2868 -- renames a Ghost entity.
2870 if Is_Entity_Name
(Nam
) then
2871 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
2874 New_S
:= Analyze_Subprogram_Specification
(Spec
);
2878 -- Renamed entity must be analyzed first, to avoid being hidden by
2879 -- new name (which might be the same in a generic instance).
2883 -- The subprogram renaming declaration may become Ghost if it renames
2886 if Is_Entity_Name
(Nam
) then
2887 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
2890 -- The renaming defines a new overloaded entity, which is analyzed
2891 -- like a subprogram declaration.
2893 New_S
:= Analyze_Subprogram_Specification
(Spec
);
2896 if Current_Scope
/= Standard_Standard
then
2897 Set_Is_Pure
(New_S
, Is_Pure
(Current_Scope
));
2900 -- Set SPARK mode from current context
2902 Set_SPARK_Pragma
(New_S
, SPARK_Mode_Pragma
);
2903 Set_SPARK_Pragma_Inherited
(New_S
);
2905 Rename_Spec
:= Find_Corresponding_Spec
(N
);
2907 -- Case of Renaming_As_Body
2909 if Present
(Rename_Spec
) then
2910 Check_Previous_Null_Procedure
(N
, Rename_Spec
);
2912 -- Renaming declaration is the completion of the declaration of
2913 -- Rename_Spec. We build an actual body for it at the freezing point.
2915 Set_Corresponding_Spec
(N
, Rename_Spec
);
2917 -- Deal with special case of stream functions of abstract types
2920 if Nkind
(Unit_Declaration_Node
(Rename_Spec
)) =
2921 N_Abstract_Subprogram_Declaration
2923 -- Input stream functions are abstract if the object type is
2924 -- abstract. Similarly, all default stream functions for an
2925 -- interface type are abstract. However, these subprograms may
2926 -- receive explicit declarations in representation clauses, making
2927 -- the attribute subprograms usable as defaults in subsequent
2929 -- In this case we rewrite the declaration to make the subprogram
2930 -- non-abstract. We remove the previous declaration, and insert
2931 -- the new one at the point of the renaming, to prevent premature
2932 -- access to unfrozen types. The new declaration reuses the
2933 -- specification of the previous one, and must not be analyzed.
2936 (Is_Primitive
(Entity
(Nam
))
2938 Is_Abstract_Type
(Find_Dispatching_Type
(Entity
(Nam
))));
2940 Old_Decl
: constant Node_Id
:=
2941 Unit_Declaration_Node
(Rename_Spec
);
2942 New_Decl
: constant Node_Id
:=
2943 Make_Subprogram_Declaration
(Sloc
(N
),
2945 Relocate_Node
(Specification
(Old_Decl
)));
2948 Insert_After
(N
, New_Decl
);
2949 Set_Is_Abstract_Subprogram
(Rename_Spec
, False);
2950 Set_Analyzed
(New_Decl
);
2954 Set_Corresponding_Body
(Unit_Declaration_Node
(Rename_Spec
), New_S
);
2956 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
2957 Error_Msg_N
("(Ada 83) renaming cannot serve as a body", N
);
2960 Set_Convention
(New_S
, Convention
(Rename_Spec
));
2961 Check_Fully_Conformant
(New_S
, Rename_Spec
);
2962 Set_Public_Status
(New_S
);
2964 if No_Return
(Rename_Spec
)
2965 and then not No_Return
(Entity
(Nam
))
2967 Error_Msg_N
("renaming completes a No_Return procedure", N
);
2969 ("\renamed procedure must be nonreturning (RM 6.5.1 (7/2))", N
);
2972 -- The specification does not introduce new formals, but only
2973 -- repeats the formals of the original subprogram declaration.
2974 -- For cross-reference purposes, and for refactoring tools, we
2975 -- treat the formals of the renaming declaration as body formals.
2977 Reference_Body_Formals
(Rename_Spec
, New_S
);
2979 -- Indicate that the entity in the declaration functions like the
2980 -- corresponding body, and is not a new entity. The body will be
2981 -- constructed later at the freeze point, so indicate that the
2982 -- completion has not been seen yet.
2984 Set_Ekind
(New_S
, E_Subprogram_Body
);
2985 New_S
:= Rename_Spec
;
2986 Set_Has_Completion
(Rename_Spec
, False);
2988 -- Ada 2005: check overriding indicator
2990 if Present
(Overridden_Operation
(Rename_Spec
)) then
2991 if Must_Not_Override
(Specification
(N
)) then
2993 ("subprogram& overrides inherited operation",
2997 and then not Must_Override
(Specification
(N
))
2999 Style
.Missing_Overriding
(N
, Rename_Spec
);
3002 elsif Must_Override
(Specification
(N
)) then
3003 Error_Msg_NE
("subprogram& is not overriding", N
, Rename_Spec
);
3006 -- Normal subprogram renaming (not renaming as body)
3009 Generate_Definition
(New_S
);
3010 New_Overloaded_Entity
(New_S
);
3012 if Is_Entity_Name
(Nam
)
3013 and then Is_Intrinsic_Subprogram
(Entity
(Nam
))
3017 Check_Delayed_Subprogram
(New_S
);
3021 -- There is no need for elaboration checks on the new entity, which may
3022 -- be called before the next freezing point where the body will appear.
3023 -- Elaboration checks refer to the real entity, not the one created by
3024 -- the renaming declaration.
3026 Set_Kill_Elaboration_Checks
(New_S
, True);
3028 -- If we had a previous error, indicate a completely is present to stop
3029 -- junk cascaded messages, but don't take any further action.
3031 if Etype
(Nam
) = Any_Type
then
3032 Set_Has_Completion
(New_S
);
3035 -- Case where name has the form of a selected component
3037 elsif Nkind
(Nam
) = N_Selected_Component
then
3039 -- A name which has the form A.B can designate an entry of task A, a
3040 -- protected operation of protected object A, or finally a primitive
3041 -- operation of object A. In the later case, A is an object of some
3042 -- tagged type, or an access type that denotes one such. To further
3043 -- distinguish these cases, note that the scope of a task entry or
3044 -- protected operation is type of the prefix.
3046 -- The prefix could be an overloaded function call that returns both
3047 -- kinds of operations. This overloading pathology is left to the
3048 -- dedicated reader ???
3051 T
: constant Entity_Id
:= Etype
(Prefix
(Nam
));
3059 and then Is_Tagged_Type
(Designated_Type
(T
))))
3060 and then Scope
(Entity
(Selector_Name
(Nam
))) /= T
3062 Analyze_Renamed_Primitive_Operation
3063 (N
, New_S
, Present
(Rename_Spec
));
3067 -- Renamed entity is an entry or protected operation. For those
3068 -- cases an explicit body is built (at the point of freezing of
3069 -- this entity) that contains a call to the renamed entity.
3071 -- This is not allowed for renaming as body if the renamed
3072 -- spec is already frozen (see RM 8.5.4(5) for details).
3074 if Present
(Rename_Spec
) and then Is_Frozen
(Rename_Spec
) then
3076 ("renaming-as-body cannot rename entry as subprogram", N
);
3078 ("\since & is already frozen (RM 8.5.4(5))",
3081 Analyze_Renamed_Entry
(N
, New_S
, Present
(Rename_Spec
));
3088 -- Case where name is an explicit dereference X.all
3090 elsif Nkind
(Nam
) = N_Explicit_Dereference
then
3092 -- Renamed entity is designated by access_to_subprogram expression.
3093 -- Must build body to encapsulate call, as in the entry case.
3095 Analyze_Renamed_Dereference
(N
, New_S
, Present
(Rename_Spec
));
3098 -- Indexed component
3100 elsif Nkind
(Nam
) = N_Indexed_Component
then
3101 Analyze_Renamed_Family_Member
(N
, New_S
, Present
(Rename_Spec
));
3104 -- Character literal
3106 elsif Nkind
(Nam
) = N_Character_Literal
then
3107 Analyze_Renamed_Character
(N
, New_S
, Present
(Rename_Spec
));
3110 -- Only remaining case is where we have a non-entity name, or a renaming
3111 -- of some other non-overloadable entity.
3113 elsif not Is_Entity_Name
(Nam
)
3114 or else not Is_Overloadable
(Entity
(Nam
))
3116 -- Do not mention the renaming if it comes from an instance
3118 if not Is_Actual
then
3119 Error_Msg_N
("expect valid subprogram name in renaming", N
);
3121 Error_Msg_NE
("no visible subprogram for formal&", N
, Nam
);
3127 -- Find the renamed entity that matches the given specification. Disable
3128 -- Ada_83 because there is no requirement of full conformance between
3129 -- renamed entity and new entity, even though the same circuit is used.
3131 -- This is a bit of an odd case, which introduces a really irregular use
3132 -- of Ada_Version[_Explicit]. Would be nice to find cleaner way to do
3135 Ada_Version
:= Ada_Version_Type
'Max (Ada_Version
, Ada_95
);
3136 Ada_Version_Pragma
:= Empty
;
3137 Ada_Version_Explicit
:= Ada_Version
;
3140 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
3142 -- The visible operation may be an inherited abstract operation that
3143 -- was overridden in the private part, in which case a call will
3144 -- dispatch to the overriding operation. Use the overriding one in
3145 -- the renaming declaration, to prevent spurious errors below.
3147 if Is_Overloadable
(Old_S
)
3148 and then Is_Abstract_Subprogram
(Old_S
)
3149 and then No
(DTC_Entity
(Old_S
))
3150 and then Present
(Alias
(Old_S
))
3151 and then not Is_Abstract_Subprogram
(Alias
(Old_S
))
3152 and then Present
(Overridden_Operation
(Alias
(Old_S
)))
3154 Old_S
:= Alias
(Old_S
);
3157 -- When the renamed subprogram is overloaded and used as an actual
3158 -- of a generic, its entity is set to the first available homonym.
3159 -- We must first disambiguate the name, then set the proper entity.
3161 if Is_Actual
and then Is_Overloaded
(Nam
) then
3162 Set_Entity
(Nam
, Old_S
);
3166 -- Most common case: subprogram renames subprogram. No body is generated
3167 -- in this case, so we must indicate the declaration is complete as is.
3168 -- and inherit various attributes of the renamed subprogram.
3170 if No
(Rename_Spec
) then
3171 Set_Has_Completion
(New_S
);
3172 Set_Is_Imported
(New_S
, Is_Imported
(Entity
(Nam
)));
3173 Set_Is_Pure
(New_S
, Is_Pure
(Entity
(Nam
)));
3174 Set_Is_Preelaborated
(New_S
, Is_Preelaborated
(Entity
(Nam
)));
3176 -- Ada 2005 (AI-423): Check the consistency of null exclusions
3177 -- between a subprogram and its correct renaming.
3179 -- Note: the Any_Id check is a guard that prevents compiler crashes
3180 -- when performing a null exclusion check between a renaming and a
3181 -- renamed subprogram that has been found to be illegal.
3183 if Ada_Version
>= Ada_2005
and then Entity
(Nam
) /= Any_Id
then
3184 Check_Null_Exclusion
3186 Sub
=> Entity
(Nam
));
3189 -- Enforce the Ada 2005 rule that the renamed entity cannot require
3190 -- overriding. The flag Requires_Overriding is set very selectively
3191 -- and misses some other illegal cases. The additional conditions
3192 -- checked below are sufficient but not necessary ???
3194 -- The rule does not apply to the renaming generated for an actual
3195 -- subprogram in an instance.
3200 -- Guard against previous errors, and omit renamings of predefined
3203 elsif not Ekind_In
(Old_S
, E_Function
, E_Procedure
) then
3206 elsif Requires_Overriding
(Old_S
)
3208 (Is_Abstract_Subprogram
(Old_S
)
3209 and then Present
(Find_Dispatching_Type
(Old_S
))
3211 not Is_Abstract_Type
(Find_Dispatching_Type
(Old_S
)))
3214 ("renamed entity cannot be subprogram that requires overriding "
3215 & "(RM 8.5.4 (5.1))", N
);
3219 Prev
: constant Entity_Id
:= Overridden_Operation
(New_S
);
3223 (Has_Non_Trivial_Precondition
(Prev
)
3224 or else Has_Non_Trivial_Precondition
(Old_S
))
3227 ("conflicting inherited classwide preconditions in renaming "
3228 & "of& (RM 6.1.1 (17)", N
, Old_S
);
3233 if Old_S
/= Any_Id
then
3234 if Is_Actual
and then From_Default
(N
) then
3236 -- This is an implicit reference to the default actual
3238 Generate_Reference
(Old_S
, Nam
, Typ
=> 'i', Force
=> True);
3241 Generate_Reference
(Old_S
, Nam
);
3244 Check_Internal_Protected_Use
(N
, Old_S
);
3246 -- For a renaming-as-body, require subtype conformance, but if the
3247 -- declaration being completed has not been frozen, then inherit the
3248 -- convention of the renamed subprogram prior to checking conformance
3249 -- (unless the renaming has an explicit convention established; the
3250 -- rule stated in the RM doesn't seem to address this ???).
3252 if Present
(Rename_Spec
) then
3253 Generate_Reference
(Rename_Spec
, Defining_Entity
(Spec
), 'b');
3254 Style
.Check_Identifier
(Defining_Entity
(Spec
), Rename_Spec
);
3256 if not Is_Frozen
(Rename_Spec
) then
3257 if not Has_Convention_Pragma
(Rename_Spec
) then
3258 Set_Convention
(New_S
, Convention
(Old_S
));
3261 if Ekind
(Old_S
) /= E_Operator
then
3262 Check_Mode_Conformant
(New_S
, Old_S
, Spec
);
3265 if Original_Subprogram
(Old_S
) = Rename_Spec
then
3266 Error_Msg_N
("unfrozen subprogram cannot rename itself ", N
);
3269 Check_Subtype_Conformant
(New_S
, Old_S
, Spec
);
3272 Check_Frozen_Renaming
(N
, Rename_Spec
);
3274 -- Check explicitly that renamed entity is not intrinsic, because
3275 -- in a generic the renamed body is not built. In this case,
3276 -- the renaming_as_body is a completion.
3278 if Inside_A_Generic
then
3279 if Is_Frozen
(Rename_Spec
)
3280 and then Is_Intrinsic_Subprogram
(Old_S
)
3283 ("subprogram in renaming_as_body cannot be intrinsic",
3287 Set_Has_Completion
(Rename_Spec
);
3290 elsif Ekind
(Old_S
) /= E_Operator
then
3292 -- If this a defaulted subprogram for a class-wide actual there is
3293 -- no check for mode conformance, given that the signatures don't
3294 -- match (the source mentions T but the actual mentions T'Class).
3298 elsif not Is_Actual
or else No
(Enclosing_Instance
) then
3299 Check_Mode_Conformant
(New_S
, Old_S
);
3302 if Is_Actual
and then Error_Posted
(New_S
) then
3303 Error_Msg_NE
("invalid actual subprogram: & #!", N
, Old_S
);
3307 if No
(Rename_Spec
) then
3309 -- The parameter profile of the new entity is that of the renamed
3310 -- entity: the subtypes given in the specification are irrelevant.
3312 Inherit_Renamed_Profile
(New_S
, Old_S
);
3314 -- A call to the subprogram is transformed into a call to the
3315 -- renamed entity. This is transitive if the renamed entity is
3316 -- itself a renaming.
3318 if Present
(Alias
(Old_S
)) then
3319 Set_Alias
(New_S
, Alias
(Old_S
));
3321 Set_Alias
(New_S
, Old_S
);
3324 -- Note that we do not set Is_Intrinsic_Subprogram if we have a
3325 -- renaming as body, since the entity in this case is not an
3326 -- intrinsic (it calls an intrinsic, but we have a real body for
3327 -- this call, and it is in this body that the required intrinsic
3328 -- processing will take place).
3330 -- Also, if this is a renaming of inequality, the renamed operator
3331 -- is intrinsic, but what matters is the corresponding equality
3332 -- operator, which may be user-defined.
3334 Set_Is_Intrinsic_Subprogram
3336 Is_Intrinsic_Subprogram
(Old_S
)
3338 (Chars
(Old_S
) /= Name_Op_Ne
3339 or else Ekind
(Old_S
) = E_Operator
3340 or else Is_Intrinsic_Subprogram
3341 (Corresponding_Equality
(Old_S
))));
3343 if Ekind
(Alias
(New_S
)) = E_Operator
then
3344 Set_Has_Delayed_Freeze
(New_S
, False);
3347 -- If the renaming corresponds to an association for an abstract
3348 -- formal subprogram, then various attributes must be set to
3349 -- indicate that the renaming is an abstract dispatching operation
3350 -- with a controlling type.
3352 if Is_Actual
and then Is_Abstract_Subprogram
(Formal_Spec
) then
3354 -- Mark the renaming as abstract here, so Find_Dispatching_Type
3355 -- see it as corresponding to a generic association for a
3356 -- formal abstract subprogram
3358 Set_Is_Abstract_Subprogram
(New_S
);
3361 New_S_Ctrl_Type
: constant Entity_Id
:=
3362 Find_Dispatching_Type
(New_S
);
3363 Old_S_Ctrl_Type
: constant Entity_Id
:=
3364 Find_Dispatching_Type
(Old_S
);
3368 -- The actual must match the (instance of the) formal,
3369 -- and must be a controlling type.
3371 if Old_S_Ctrl_Type
/= New_S_Ctrl_Type
3372 or else No
(New_S_Ctrl_Type
)
3375 ("actual must be dispatching subprogram for type&",
3376 Nam
, New_S_Ctrl_Type
);
3379 Set_Is_Dispatching_Operation
(New_S
);
3380 Check_Controlling_Formals
(New_S_Ctrl_Type
, New_S
);
3382 -- If the actual in the formal subprogram is itself a
3383 -- formal abstract subprogram association, there's no
3384 -- dispatch table component or position to inherit.
3386 if Present
(DTC_Entity
(Old_S
)) then
3387 Set_DTC_Entity
(New_S
, DTC_Entity
(Old_S
));
3388 Set_DT_Position_Value
(New_S
, DT_Position
(Old_S
));
3398 -- The following is illegal, because F hides whatever other F may
3400 -- function F (...) renames F;
3403 or else (Nkind
(Nam
) /= N_Expanded_Name
3404 and then Chars
(Old_S
) = Chars
(New_S
))
3406 Error_Msg_N
("subprogram cannot rename itself", N
);
3408 -- This is illegal even if we use a selector:
3409 -- function F (...) renames Pkg.F;
3410 -- because F is still hidden.
3412 elsif Nkind
(Nam
) = N_Expanded_Name
3413 and then Entity
(Prefix
(Nam
)) = Current_Scope
3414 and then Chars
(Selector_Name
(Nam
)) = Chars
(New_S
)
3416 -- This is an error, but we overlook the error and accept the
3417 -- renaming if the special Overriding_Renamings mode is in effect.
3419 if not Overriding_Renamings
then
3421 ("implicit operation& is not visible (RM 8.3 (15))",
3426 Set_Convention
(New_S
, Convention
(Old_S
));
3428 if Is_Abstract_Subprogram
(Old_S
) then
3429 if Present
(Rename_Spec
) then
3431 ("a renaming-as-body cannot rename an abstract subprogram",
3433 Set_Has_Completion
(Rename_Spec
);
3435 Set_Is_Abstract_Subprogram
(New_S
);
3439 Check_Library_Unit_Renaming
(N
, Old_S
);
3441 -- Pathological case: procedure renames entry in the scope of its
3442 -- task. Entry is given by simple name, but body must be built for
3443 -- procedure. Of course if called it will deadlock.
3445 if Ekind
(Old_S
) = E_Entry
then
3446 Set_Has_Completion
(New_S
, False);
3447 Set_Alias
(New_S
, Empty
);
3450 -- Do not freeze the renaming nor the renamed entity when the context
3451 -- is an enclosing generic. Freezing is an expansion activity, and in
3452 -- addition the renamed entity may depend on the generic formals of
3453 -- the enclosing generic.
3455 if Is_Actual
and not Inside_A_Generic
then
3456 Freeze_Before
(N
, Old_S
);
3457 Freeze_Actual_Profile
;
3458 Set_Has_Delayed_Freeze
(New_S
, False);
3459 Freeze_Before
(N
, New_S
);
3461 -- An abstract subprogram is only allowed as an actual in the case
3462 -- where the formal subprogram is also abstract.
3464 if (Ekind
(Old_S
) = E_Procedure
or else Ekind
(Old_S
) = E_Function
)
3465 and then Is_Abstract_Subprogram
(Old_S
)
3466 and then not Is_Abstract_Subprogram
(Formal_Spec
)
3469 ("abstract subprogram not allowed as generic actual", Nam
);
3474 -- A common error is to assume that implicit operators for types are
3475 -- defined in Standard, or in the scope of a subtype. In those cases
3476 -- where the renamed entity is given with an expanded name, it is
3477 -- worth mentioning that operators for the type are not declared in
3478 -- the scope given by the prefix.
3480 if Nkind
(Nam
) = N_Expanded_Name
3481 and then Nkind
(Selector_Name
(Nam
)) = N_Operator_Symbol
3482 and then Scope
(Entity
(Nam
)) = Standard_Standard
3485 T
: constant Entity_Id
:=
3486 Base_Type
(Etype
(First_Formal
(New_S
)));
3488 Error_Msg_Node_2
:= Prefix
(Nam
);
3490 ("operator for type& is not declared in&", Prefix
(Nam
), T
);
3495 ("no visible subprogram matches the specification for&",
3499 if Present
(Candidate_Renaming
) then
3506 F1
:= First_Formal
(Candidate_Renaming
);
3507 F2
:= First_Formal
(New_S
);
3508 T1
:= First_Subtype
(Etype
(F1
));
3509 while Present
(F1
) and then Present
(F2
) loop
3514 if Present
(F1
) and then Present
(Default_Value
(F1
)) then
3515 if Present
(Next_Formal
(F1
)) then
3517 ("\missing specification for & and other formals with "
3518 & "defaults", Spec
, F1
);
3520 Error_Msg_NE
("\missing specification for &", Spec
, F1
);
3524 if Nkind
(Nam
) = N_Operator_Symbol
3525 and then From_Default
(N
)
3527 Error_Msg_Node_2
:= T1
;
3529 ("default & on & is not directly visible", Nam
, Nam
);
3535 -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that
3536 -- controlling access parameters are known non-null for the renamed
3537 -- subprogram. Test also applies to a subprogram instantiation that
3538 -- is dispatching. Test is skipped if some previous error was detected
3539 -- that set Old_S to Any_Id.
3541 if Ada_Version
>= Ada_2005
3542 and then Old_S
/= Any_Id
3543 and then not Is_Dispatching_Operation
(Old_S
)
3544 and then Is_Dispatching_Operation
(New_S
)
3551 Old_F
:= First_Formal
(Old_S
);
3552 New_F
:= First_Formal
(New_S
);
3553 while Present
(Old_F
) loop
3554 if Ekind
(Etype
(Old_F
)) = E_Anonymous_Access_Type
3555 and then Is_Controlling_Formal
(New_F
)
3556 and then not Can_Never_Be_Null
(Old_F
)
3558 Error_Msg_N
("access parameter is controlling,", New_F
);
3560 ("\corresponding parameter of& must be explicitly null "
3561 & "excluding", New_F
, Old_S
);
3564 Next_Formal
(Old_F
);
3565 Next_Formal
(New_F
);
3570 -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005)
3571 -- is to warn if an operator is being renamed as a different operator.
3572 -- If the operator is predefined, examine the kind of the entity, not
3573 -- the abbreviated declaration in Standard.
3575 if Comes_From_Source
(N
)
3576 and then Present
(Old_S
)
3577 and then (Nkind
(Old_S
) = N_Defining_Operator_Symbol
3578 or else Ekind
(Old_S
) = E_Operator
)
3579 and then Nkind
(New_S
) = N_Defining_Operator_Symbol
3580 and then Chars
(Old_S
) /= Chars
(New_S
)
3583 ("& is being renamed as a different operator??", N
, Old_S
);
3586 -- Check for renaming of obsolescent subprogram
3588 Check_Obsolescent_2005_Entity
(Entity
(Nam
), Nam
);
3590 -- Another warning or some utility: if the new subprogram as the same
3591 -- name as the old one, the old one is not hidden by an outer homograph,
3592 -- the new one is not a public symbol, and the old one is otherwise
3593 -- directly visible, the renaming is superfluous.
3595 if Chars
(Old_S
) = Chars
(New_S
)
3596 and then Comes_From_Source
(N
)
3597 and then Scope
(Old_S
) /= Standard_Standard
3598 and then Warn_On_Redundant_Constructs
3599 and then (Is_Immediately_Visible
(Old_S
)
3600 or else Is_Potentially_Use_Visible
(Old_S
))
3601 and then Is_Overloadable
(Current_Scope
)
3602 and then Chars
(Current_Scope
) /= Chars
(Old_S
)
3605 ("redundant renaming, entity is directly visible?r?", Name
(N
));
3608 -- Implementation-defined aspect specifications can appear in a renaming
3609 -- declaration, but not language-defined ones. The call to procedure
3610 -- Analyze_Aspect_Specifications will take care of this error check.
3612 if Has_Aspects
(N
) then
3613 Analyze_Aspect_Specifications
(N
, New_S
);
3616 Ada_Version
:= Save_AV
;
3617 Ada_Version_Pragma
:= Save_AVP
;
3618 Ada_Version_Explicit
:= Save_AV_Exp
;
3620 -- In GNATprove mode, the renamings of actual subprograms are replaced
3621 -- with wrapper functions that make it easier to propagate axioms to the
3622 -- points of call within an instance. Wrappers are generated if formal
3623 -- subprogram is subject to axiomatization.
3625 -- The types in the wrapper profiles are obtained from (instances of)
3626 -- the types of the formal subprogram.
3629 and then GNATprove_Mode
3630 and then Present
(Containing_Package_With_Ext_Axioms
(Formal_Spec
))
3631 and then not Inside_A_Generic
3633 if Ekind
(Old_S
) = E_Function
then
3634 Rewrite
(N
, Build_Function_Wrapper
(Formal_Spec
, Old_S
));
3637 elsif Ekind
(Old_S
) = E_Operator
then
3638 Rewrite
(N
, Build_Operator_Wrapper
(Formal_Spec
, Old_S
));
3643 -- Check if we are looking at an Ada 2012 defaulted formal subprogram
3644 -- and mark any use_package_clauses that affect the visibility of the
3645 -- implicit generic actual.
3648 and then Is_Generic_Actual_Subprogram
(New_S
)
3649 and then Present
(Alias
(New_S
))
3651 Mark_Use_Clauses
(Alias
(New_S
));
3653 -- Check intrinsic operators used as generic actuals since they may
3654 -- make a use_type_clause effective.
3656 elsif Is_Generic_Actual_Subprogram
(New_S
)
3657 and then Is_Intrinsic_Subprogram
(New_S
)
3659 Mark_Use_Clauses
(New_S
);
3661 end Analyze_Subprogram_Renaming
;
3663 -------------------------
3664 -- Analyze_Use_Package --
3665 -------------------------
3667 -- Resolve the package names in the use clause, and make all the visible
3668 -- entities defined in the package potentially use-visible. If the package
3669 -- is already in use from a previous use clause, its visible entities are
3670 -- already use-visible. In that case, mark the occurrence as a redundant
3671 -- use. If the package is an open scope, i.e. if the use clause occurs
3672 -- within the package itself, ignore it.
3674 procedure Analyze_Use_Package
(N
: Node_Id
; Chain
: Boolean := True) is
3675 procedure Analyze_Package_Name
(Clause
: Node_Id
);
3676 -- Perform analysis on a package name from a use_package_clause
3678 procedure Analyze_Package_Name_List
(Head_Clause
: Node_Id
);
3679 -- Similar to Analyze_Package_Name but iterates over all the names
3682 --------------------------
3683 -- Analyze_Package_Name --
3684 --------------------------
3686 procedure Analyze_Package_Name
(Clause
: Node_Id
) is
3687 Pack
: constant Node_Id
:= Name
(Clause
);
3691 pragma Assert
(Nkind
(Clause
) = N_Use_Package_Clause
);
3694 -- Verify that the package standard is not directly named in a
3695 -- use_package_clause.
3697 if Nkind
(Parent
(Clause
)) = N_Compilation_Unit
3698 and then Nkind
(Pack
) = N_Expanded_Name
3700 Pref
:= Prefix
(Pack
);
3702 while Nkind
(Pref
) = N_Expanded_Name
loop
3703 Pref
:= Prefix
(Pref
);
3706 if Entity
(Pref
) = Standard_Standard
then
3708 ("predefined package Standard cannot appear in a context "
3712 end Analyze_Package_Name
;
3714 -------------------------------
3715 -- Analyze_Package_Name_List --
3716 -------------------------------
3718 procedure Analyze_Package_Name_List
(Head_Clause
: Node_Id
) is
3722 -- Due to the way source use clauses are split during parsing we are
3723 -- forced to simply iterate through all entities in scope until the
3724 -- clause representing the last name in the list is found.
3726 Curr
:= Head_Clause
;
3727 while Present
(Curr
) loop
3728 Analyze_Package_Name
(Curr
);
3730 -- Stop iterating over the names in the use clause when we are at
3733 exit when not More_Ids
(Curr
) and then Prev_Ids
(Curr
);
3736 end Analyze_Package_Name_List
;
3740 Ghost_Id
: Entity_Id
:= Empty
;
3741 Living_Id
: Entity_Id
:= Empty
;
3744 -- Start of processing for Analyze_Use_Package
3747 Check_SPARK_05_Restriction
("use clause is not allowed", N
);
3749 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
3751 -- Use clause not allowed in a spec of a predefined package declaration
3752 -- except that packages whose file name starts a-n are OK (these are
3753 -- children of Ada.Numerics, which are never loaded by Rtsfind).
3755 if Is_Predefined_Unit
(Current_Sem_Unit
)
3756 and then Get_Name_String
3757 (Unit_File_Name
(Current_Sem_Unit
)) (1 .. 3) /= "a-n"
3758 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
3759 N_Package_Declaration
3761 Error_Msg_N
("use clause not allowed in predefined spec", N
);
3764 -- Loop through all package names from the original use clause in
3765 -- order to analyze referenced packages. A use_package_clause with only
3766 -- one name does not have More_Ids or Prev_Ids set, while a clause with
3767 -- More_Ids only starts the chain produced by the parser.
3769 if not More_Ids
(N
) and then not Prev_Ids
(N
) then
3770 Analyze_Package_Name
(N
);
3772 elsif More_Ids
(N
) and then not Prev_Ids
(N
) then
3773 Analyze_Package_Name_List
(N
);
3776 if not Is_Entity_Name
(Name
(N
)) then
3777 Error_Msg_N
("& is not a package", Name
(N
));
3783 Chain_Use_Clause
(N
);
3786 Pack
:= Entity
(Name
(N
));
3788 -- There are many cases where scopes are manipulated during analysis, so
3789 -- check that Pack's current use clause has not already been chained
3790 -- before setting its previous use clause.
3792 if Ekind
(Pack
) = E_Package
3793 and then Present
(Current_Use_Clause
(Pack
))
3794 and then Current_Use_Clause
(Pack
) /= N
3795 and then No
(Prev_Use_Clause
(N
))
3796 and then Prev_Use_Clause
(Current_Use_Clause
(Pack
)) /= N
3798 Set_Prev_Use_Clause
(N
, Current_Use_Clause
(Pack
));
3801 -- Mark all entities as potentially use visible.
3803 if Ekind
(Pack
) /= E_Package
and then Etype
(Pack
) /= Any_Type
then
3804 if Ekind
(Pack
) = E_Generic_Package
then
3805 Error_Msg_N
-- CODEFIX
3806 ("a generic package is not allowed in a use clause", Name
(N
));
3808 elsif Ekind_In
(Pack
, E_Generic_Function
, E_Generic_Package
)
3810 Error_Msg_N
-- CODEFIX
3811 ("a generic subprogram is not allowed in a use clause",
3814 elsif Ekind_In
(Pack
, E_Function
, E_Procedure
, E_Operator
) then
3815 Error_Msg_N
-- CODEFIX
3816 ("a subprogram is not allowed in a use clause", Name
(N
));
3819 Error_Msg_N
("& is not allowed in a use clause", Name
(N
));
3823 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3824 Check_In_Previous_With_Clause
(N
, Name
(N
));
3827 Use_One_Package
(N
, Name
(N
));
3829 -- Capture the first Ghost package and the first living package
3831 if Is_Entity_Name
(Name
(N
)) then
3832 Pack
:= Entity
(Name
(N
));
3834 if Is_Ghost_Entity
(Pack
) then
3835 if No
(Ghost_Id
) then
3839 elsif No
(Living_Id
) then
3844 end Analyze_Use_Package
;
3846 ----------------------
3847 -- Analyze_Use_Type --
3848 ----------------------
3850 procedure Analyze_Use_Type
(N
: Node_Id
; Chain
: Boolean := True) is
3855 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
3857 -- Chain clause to list of use clauses in current scope when flagged
3860 Chain_Use_Clause
(N
);
3863 -- Obtain the base type of the type denoted within the use_type_clause's
3866 Id
:= Subtype_Mark
(N
);
3868 E
:= Base_Type
(Entity
(Id
));
3870 -- There are many cases where a use_type_clause may be reanalyzed due to
3871 -- manipulation of the scope stack so we much guard against those cases
3872 -- here, otherwise, we must add the new use_type_clause to the previous
3873 -- use_type_clause chain in order to mark redundant use_type_clauses as
3876 if Present
(Current_Use_Clause
(E
))
3877 and then Current_Use_Clause
(E
) /= N
3878 and then No
(Prev_Use_Clause
(N
))
3880 Set_Prev_Use_Clause
(N
, Current_Use_Clause
(E
));
3883 -- If the Used_Operations list is already initialized, the clause has
3884 -- been analyzed previously, and it is being reinstalled, for example
3885 -- when the clause appears in a package spec and we are compiling the
3886 -- corresponding package body. In that case, make the entities on the
3887 -- existing list use_visible, and mark the corresponding types In_Use.
3889 if Present
(Used_Operations
(N
)) then
3894 Use_One_Type
(Subtype_Mark
(N
), Installed
=> True);
3896 Elmt
:= First_Elmt
(Used_Operations
(N
));
3897 while Present
(Elmt
) loop
3898 Set_Is_Potentially_Use_Visible
(Node
(Elmt
));
3906 -- Otherwise, create new list and attach to it the operations that are
3907 -- made use-visible by the clause.
3909 Set_Used_Operations
(N
, New_Elmt_List
);
3912 if E
/= Any_Type
then
3915 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3916 if Nkind
(Id
) = N_Identifier
then
3917 Error_Msg_N
("type is not directly visible", Id
);
3919 elsif Is_Child_Unit
(Scope
(E
))
3920 and then Scope
(E
) /= System_Aux_Id
3922 Check_In_Previous_With_Clause
(N
, Prefix
(Id
));
3927 -- If the use_type_clause appears in a compilation unit context,
3928 -- check whether it comes from a unit that may appear in a
3929 -- limited_with_clause, for a better error message.
3931 if Nkind
(Parent
(N
)) = N_Compilation_Unit
3932 and then Nkind
(Id
) /= N_Identifier
3938 function Mentioned
(Nam
: Node_Id
) return Boolean;
3939 -- Check whether the prefix of expanded name for the type
3940 -- appears in the prefix of some limited_with_clause.
3946 function Mentioned
(Nam
: Node_Id
) return Boolean is
3948 return Nkind
(Name
(Item
)) = N_Selected_Component
3949 and then Chars
(Prefix
(Name
(Item
))) = Chars
(Nam
);
3953 Pref
:= Prefix
(Id
);
3954 Item
:= First
(Context_Items
(Parent
(N
)));
3955 while Present
(Item
) and then Item
/= N
loop
3956 if Nkind
(Item
) = N_With_Clause
3957 and then Limited_Present
(Item
)
3958 and then Mentioned
(Pref
)
3961 (Get_Msg_Id
, "premature usage of incomplete type");
3970 Mark_Ghost_Clause
(N
);
3971 end Analyze_Use_Type
;
3973 ------------------------
3974 -- Attribute_Renaming --
3975 ------------------------
3977 procedure Attribute_Renaming
(N
: Node_Id
) is
3978 Loc
: constant Source_Ptr
:= Sloc
(N
);
3979 Nam
: constant Node_Id
:= Name
(N
);
3980 Spec
: constant Node_Id
:= Specification
(N
);
3981 New_S
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
3982 Aname
: constant Name_Id
:= Attribute_Name
(Nam
);
3984 Form_Num
: Nat
:= 0;
3985 Expr_List
: List_Id
:= No_List
;
3987 Attr_Node
: Node_Id
;
3988 Body_Node
: Node_Id
;
3989 Param_Spec
: Node_Id
;
3992 Generate_Definition
(New_S
);
3994 -- This procedure is called in the context of subprogram renaming, and
3995 -- thus the attribute must be one that is a subprogram. All of those
3996 -- have at least one formal parameter, with the exceptions of the GNAT
3997 -- attribute 'Img, which GNAT treats as renameable.
3999 if not Is_Non_Empty_List
(Parameter_Specifications
(Spec
)) then
4000 if Aname
/= Name_Img
then
4002 ("subprogram renaming an attribute must have formals", N
);
4007 Param_Spec
:= First
(Parameter_Specifications
(Spec
));
4008 while Present
(Param_Spec
) loop
4009 Form_Num
:= Form_Num
+ 1;
4011 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
4012 Find_Type
(Parameter_Type
(Param_Spec
));
4014 -- The profile of the new entity denotes the base type (s) of
4015 -- the types given in the specification. For access parameters
4016 -- there are no subtypes involved.
4018 Rewrite
(Parameter_Type
(Param_Spec
),
4020 (Base_Type
(Entity
(Parameter_Type
(Param_Spec
))), Loc
));
4023 if No
(Expr_List
) then
4024 Expr_List
:= New_List
;
4027 Append_To
(Expr_List
,
4028 Make_Identifier
(Loc
,
4029 Chars
=> Chars
(Defining_Identifier
(Param_Spec
))));
4031 -- The expressions in the attribute reference are not freeze
4032 -- points. Neither is the attribute as a whole, see below.
4034 Set_Must_Not_Freeze
(Last
(Expr_List
));
4039 -- Immediate error if too many formals. Other mismatches in number or
4040 -- types of parameters are detected when we analyze the body of the
4041 -- subprogram that we construct.
4043 if Form_Num
> 2 then
4044 Error_Msg_N
("too many formals for attribute", N
);
4046 -- Error if the attribute reference has expressions that look like
4047 -- formal parameters.
4049 elsif Present
(Expressions
(Nam
)) then
4050 Error_Msg_N
("illegal expressions in attribute reference", Nam
);
4053 Nam_In
(Aname
, Name_Compose
, Name_Exponent
, Name_Leading_Part
,
4054 Name_Pos
, Name_Round
, Name_Scaling
,
4057 if Nkind
(N
) = N_Subprogram_Renaming_Declaration
4058 and then Present
(Corresponding_Formal_Spec
(N
))
4061 ("generic actual cannot be attribute involving universal type",
4065 ("attribute involving a universal type cannot be renamed",
4070 -- Rewrite attribute node to have a list of expressions corresponding to
4071 -- the subprogram formals. A renaming declaration is not a freeze point,
4072 -- and the analysis of the attribute reference should not freeze the
4073 -- type of the prefix. We use the original node in the renaming so that
4074 -- its source location is preserved, and checks on stream attributes are
4075 -- properly applied.
4077 Attr_Node
:= Relocate_Node
(Nam
);
4078 Set_Expressions
(Attr_Node
, Expr_List
);
4080 Set_Must_Not_Freeze
(Attr_Node
);
4081 Set_Must_Not_Freeze
(Prefix
(Nam
));
4083 -- Case of renaming a function
4085 if Nkind
(Spec
) = N_Function_Specification
then
4086 if Is_Procedure_Attribute_Name
(Aname
) then
4087 Error_Msg_N
("attribute can only be renamed as procedure", Nam
);
4091 Find_Type
(Result_Definition
(Spec
));
4092 Rewrite
(Result_Definition
(Spec
),
4094 (Base_Type
(Entity
(Result_Definition
(Spec
))), Loc
));
4097 Make_Subprogram_Body
(Loc
,
4098 Specification
=> Spec
,
4099 Declarations
=> New_List
,
4100 Handled_Statement_Sequence
=>
4101 Make_Handled_Sequence_Of_Statements
(Loc
,
4102 Statements
=> New_List
(
4103 Make_Simple_Return_Statement
(Loc
,
4104 Expression
=> Attr_Node
))));
4106 -- Case of renaming a procedure
4109 if not Is_Procedure_Attribute_Name
(Aname
) then
4110 Error_Msg_N
("attribute can only be renamed as function", Nam
);
4115 Make_Subprogram_Body
(Loc
,
4116 Specification
=> Spec
,
4117 Declarations
=> New_List
,
4118 Handled_Statement_Sequence
=>
4119 Make_Handled_Sequence_Of_Statements
(Loc
,
4120 Statements
=> New_List
(Attr_Node
)));
4123 -- Signal the ABE mechanism that the generated subprogram body has not
4124 -- ABE ramifications.
4126 Set_Was_Attribute_Reference
(Body_Node
);
4128 -- In case of tagged types we add the body of the generated function to
4129 -- the freezing actions of the type (because in the general case such
4130 -- type is still not frozen). We exclude from this processing generic
4131 -- formal subprograms found in instantiations.
4133 -- We must exclude restricted run-time libraries because
4134 -- entity AST_Handler is defined in package System.Aux_Dec which is not
4135 -- available in those platforms. Note that we cannot use the function
4136 -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because
4137 -- the ZFP run-time library is not defined as a profile, and we do not
4138 -- want to deal with AST_Handler in ZFP mode.
4140 if not Configurable_Run_Time_Mode
4141 and then not Present
(Corresponding_Formal_Spec
(N
))
4142 and then Etype
(Nam
) /= RTE
(RE_AST_Handler
)
4145 P
: constant Node_Id
:= Prefix
(Nam
);
4148 -- The prefix of 'Img is an object that is evaluated for each call
4149 -- of the function that renames it.
4151 if Aname
= Name_Img
then
4152 Preanalyze_And_Resolve
(P
);
4154 -- For all other attribute renamings, the prefix is a subtype
4160 -- If the target type is not yet frozen, add the body to the
4161 -- actions to be elaborated at freeze time.
4163 if Is_Tagged_Type
(Etype
(P
))
4164 and then In_Open_Scopes
(Scope
(Etype
(P
)))
4166 Ensure_Freeze_Node
(Etype
(P
));
4167 Append_Freeze_Action
(Etype
(P
), Body_Node
);
4169 Rewrite
(N
, Body_Node
);
4171 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
4175 -- Generic formal subprograms or AST_Handler renaming
4178 Rewrite
(N
, Body_Node
);
4180 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
4183 if Is_Compilation_Unit
(New_S
) then
4185 ("a library unit can only rename another library unit", N
);
4187 end Attribute_Renaming
;
4189 ----------------------
4190 -- Chain_Use_Clause --
4191 ----------------------
4193 procedure Chain_Use_Clause
(N
: Node_Id
) is
4194 Level
: Int
:= Scope_Stack
.Last
;
4200 if not Is_Compilation_Unit
(Current_Scope
)
4201 or else not Is_Child_Unit
(Current_Scope
)
4205 -- Common case for compilation unit
4207 elsif Defining_Entity
(N
=> Parent
(N
),
4208 Empty_On_Errors
=> True) = Current_Scope
4213 -- If declaration appears in some other scope, it must be in some
4214 -- parent unit when compiling a child.
4216 Pack
:= Defining_Entity
(Parent
(N
), Empty_On_Errors
=> True);
4218 if not In_Open_Scopes
(Pack
) then
4221 -- If the use clause appears in an ancestor and we are in the
4222 -- private part of the immediate parent, the use clauses are
4223 -- already installed.
4225 elsif Pack
/= Scope
(Current_Scope
)
4226 and then In_Private_Part
(Scope
(Current_Scope
))
4231 -- Find entry for parent unit in scope stack
4233 while Scope_Stack
.Table
(Level
).Entity
/= Pack
loop
4239 Set_Next_Use_Clause
(N
,
4240 Scope_Stack
.Table
(Level
).First_Use_Clause
);
4241 Scope_Stack
.Table
(Level
).First_Use_Clause
:= N
;
4242 end Chain_Use_Clause
;
4244 ---------------------------
4245 -- Check_Frozen_Renaming --
4246 ---------------------------
4248 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
) is
4253 if Is_Frozen
(Subp
) and then not Has_Completion
(Subp
) then
4256 (Parent
(Declaration_Node
(Subp
)), Defining_Entity
(N
));
4258 if Is_Entity_Name
(Name
(N
)) then
4259 Old_S
:= Entity
(Name
(N
));
4261 if not Is_Frozen
(Old_S
)
4262 and then Operating_Mode
/= Check_Semantics
4264 Append_Freeze_Action
(Old_S
, B_Node
);
4266 Insert_After
(N
, B_Node
);
4270 if Is_Intrinsic_Subprogram
(Old_S
) and then not In_Instance
then
4272 ("subprogram used in renaming_as_body cannot be intrinsic",
4277 Insert_After
(N
, B_Node
);
4281 end Check_Frozen_Renaming
;
4283 -------------------------------
4284 -- Set_Entity_Or_Discriminal --
4285 -------------------------------
4287 procedure Set_Entity_Or_Discriminal
(N
: Node_Id
; E
: Entity_Id
) is
4291 -- If the entity is not a discriminant, or else expansion is disabled,
4292 -- simply set the entity.
4294 if not In_Spec_Expression
4295 or else Ekind
(E
) /= E_Discriminant
4296 or else Inside_A_Generic
4298 Set_Entity_With_Checks
(N
, E
);
4300 -- The replacement of a discriminant by the corresponding discriminal
4301 -- is not done for a task discriminant that appears in a default
4302 -- expression of an entry parameter. See Exp_Ch2.Expand_Discriminant
4303 -- for details on their handling.
4305 elsif Is_Concurrent_Type
(Scope
(E
)) then
4308 and then not Nkind_In
(P
, N_Parameter_Specification
,
4309 N_Component_Declaration
)
4315 and then Nkind
(P
) = N_Parameter_Specification
4320 Set_Entity
(N
, Discriminal
(E
));
4323 -- Otherwise, this is a discriminant in a context in which
4324 -- it is a reference to the corresponding parameter of the
4325 -- init proc for the enclosing type.
4328 Set_Entity
(N
, Discriminal
(E
));
4330 end Set_Entity_Or_Discriminal
;
4332 -----------------------------------
4333 -- Check_In_Previous_With_Clause --
4334 -----------------------------------
4336 procedure Check_In_Previous_With_Clause
4340 Pack
: constant Entity_Id
:= Entity
(Original_Node
(Nam
));
4345 Item
:= First
(Context_Items
(Parent
(N
)));
4346 while Present
(Item
) and then Item
/= N
loop
4347 if Nkind
(Item
) = N_With_Clause
4349 -- Protect the frontend against previous critical errors
4351 and then Nkind
(Name
(Item
)) /= N_Selected_Component
4352 and then Entity
(Name
(Item
)) = Pack
4356 -- Find root library unit in with_clause
4358 while Nkind
(Par
) = N_Expanded_Name
loop
4359 Par
:= Prefix
(Par
);
4362 if Is_Child_Unit
(Entity
(Original_Node
(Par
))) then
4363 Error_Msg_NE
("& is not directly visible", Par
, Entity
(Par
));
4372 -- On exit, package is not mentioned in a previous with_clause.
4373 -- Check if its prefix is.
4375 if Nkind
(Nam
) = N_Expanded_Name
then
4376 Check_In_Previous_With_Clause
(N
, Prefix
(Nam
));
4378 elsif Pack
/= Any_Id
then
4379 Error_Msg_NE
("& is not visible", Nam
, Pack
);
4381 end Check_In_Previous_With_Clause
;
4383 ---------------------------------
4384 -- Check_Library_Unit_Renaming --
4385 ---------------------------------
4387 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
) is
4391 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4394 -- Check for library unit. Note that we used to check for the scope
4395 -- being Standard here, but that was wrong for Standard itself.
4397 elsif not Is_Compilation_Unit
(Old_E
)
4398 and then not Is_Child_Unit
(Old_E
)
4400 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
4402 -- Entities defined in Standard (operators and boolean literals) cannot
4403 -- be renamed as library units.
4405 elsif Scope
(Old_E
) = Standard_Standard
4406 and then Sloc
(Old_E
) = Standard_Location
4408 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
4410 elsif Present
(Parent_Spec
(N
))
4411 and then Nkind
(Unit
(Parent_Spec
(N
))) = N_Generic_Package_Declaration
4412 and then not Is_Child_Unit
(Old_E
)
4415 ("renamed unit must be a child unit of generic parent", Name
(N
));
4417 elsif Nkind
(N
) in N_Generic_Renaming_Declaration
4418 and then Nkind
(Name
(N
)) = N_Expanded_Name
4419 and then Is_Generic_Instance
(Entity
(Prefix
(Name
(N
))))
4420 and then Is_Generic_Unit
(Old_E
)
4423 ("renamed generic unit must be a library unit", Name
(N
));
4425 elsif Is_Package_Or_Generic_Package
(Old_E
) then
4427 -- Inherit categorization flags
4429 New_E
:= Defining_Entity
(N
);
4430 Set_Is_Pure
(New_E
, Is_Pure
(Old_E
));
4431 Set_Is_Preelaborated
(New_E
, Is_Preelaborated
(Old_E
));
4432 Set_Is_Remote_Call_Interface
(New_E
,
4433 Is_Remote_Call_Interface
(Old_E
));
4434 Set_Is_Remote_Types
(New_E
, Is_Remote_Types
(Old_E
));
4435 Set_Is_Shared_Passive
(New_E
, Is_Shared_Passive
(Old_E
));
4437 end Check_Library_Unit_Renaming
;
4439 ------------------------
4440 -- Enclosing_Instance --
4441 ------------------------
4443 function Enclosing_Instance
return Entity_Id
is
4447 if not Is_Generic_Instance
(Current_Scope
) then
4451 S
:= Scope
(Current_Scope
);
4452 while S
/= Standard_Standard
loop
4453 if Is_Generic_Instance
(S
) then
4461 end Enclosing_Instance
;
4467 procedure End_Scope
is
4473 Id
:= First_Entity
(Current_Scope
);
4474 while Present
(Id
) loop
4475 -- An entity in the current scope is not necessarily the first one
4476 -- on its homonym chain. Find its predecessor if any,
4477 -- If it is an internal entity, it will not be in the visibility
4478 -- chain altogether, and there is nothing to unchain.
4480 if Id
/= Current_Entity
(Id
) then
4481 Prev
:= Current_Entity
(Id
);
4482 while Present
(Prev
)
4483 and then Present
(Homonym
(Prev
))
4484 and then Homonym
(Prev
) /= Id
4486 Prev
:= Homonym
(Prev
);
4489 -- Skip to end of loop if Id is not in the visibility chain
4491 if No
(Prev
) or else Homonym
(Prev
) /= Id
then
4499 Set_Is_Immediately_Visible
(Id
, False);
4501 Outer
:= Homonym
(Id
);
4502 while Present
(Outer
) and then Scope
(Outer
) = Current_Scope
loop
4503 Outer
:= Homonym
(Outer
);
4506 -- Reset homonym link of other entities, but do not modify link
4507 -- between entities in current scope, so that the back-end can have
4508 -- a proper count of local overloadings.
4511 Set_Name_Entity_Id
(Chars
(Id
), Outer
);
4513 elsif Scope
(Prev
) /= Scope
(Id
) then
4514 Set_Homonym
(Prev
, Outer
);
4521 -- If the scope generated freeze actions, place them before the
4522 -- current declaration and analyze them. Type declarations and
4523 -- the bodies of initialization procedures can generate such nodes.
4524 -- We follow the parent chain until we reach a list node, which is
4525 -- the enclosing list of declarations. If the list appears within
4526 -- a protected definition, move freeze nodes outside the protected
4530 (Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
)
4534 L
: constant List_Id
:= Scope_Stack
.Table
4535 (Scope_Stack
.Last
).Pending_Freeze_Actions
;
4538 if Is_Itype
(Current_Scope
) then
4539 Decl
:= Associated_Node_For_Itype
(Current_Scope
);
4541 Decl
:= Parent
(Current_Scope
);
4546 while not (Is_List_Member
(Decl
))
4547 or else Nkind_In
(Parent
(Decl
), N_Protected_Definition
,
4550 Decl
:= Parent
(Decl
);
4553 Insert_List_Before_And_Analyze
(Decl
, L
);
4561 ---------------------
4562 -- End_Use_Clauses --
4563 ---------------------
4565 procedure End_Use_Clauses
(Clause
: Node_Id
) is
4569 -- Remove use_type_clauses first, because they affect the visibility of
4570 -- operators in subsequent used packages.
4573 while Present
(U
) loop
4574 if Nkind
(U
) = N_Use_Type_Clause
then
4578 Next_Use_Clause
(U
);
4582 while Present
(U
) loop
4583 if Nkind
(U
) = N_Use_Package_Clause
then
4584 End_Use_Package
(U
);
4587 Next_Use_Clause
(U
);
4589 end End_Use_Clauses
;
4591 ---------------------
4592 -- End_Use_Package --
4593 ---------------------
4595 procedure End_Use_Package
(N
: Node_Id
) is
4597 Pack_Name
: Node_Id
;
4601 function Is_Primitive_Operator_In_Use
4603 F
: Entity_Id
) return Boolean;
4604 -- Check whether Op is a primitive operator of a use-visible type
4606 ----------------------------------
4607 -- Is_Primitive_Operator_In_Use --
4608 ----------------------------------
4610 function Is_Primitive_Operator_In_Use
4612 F
: Entity_Id
) return Boolean
4614 T
: constant Entity_Id
:= Base_Type
(Etype
(F
));
4616 return In_Use
(T
) and then Scope
(T
) = Scope
(Op
);
4617 end Is_Primitive_Operator_In_Use
;
4619 -- Start of processing for End_Use_Package
4622 Pack_Name
:= Name
(N
);
4624 -- Test that Pack_Name actually denotes a package before processing
4626 if Is_Entity_Name
(Pack_Name
)
4627 and then Ekind
(Entity
(Pack_Name
)) = E_Package
4629 Pack
:= Entity
(Pack_Name
);
4631 if In_Open_Scopes
(Pack
) then
4634 elsif not Redundant_Use
(Pack_Name
) then
4635 Set_In_Use
(Pack
, False);
4636 Set_Current_Use_Clause
(Pack
, Empty
);
4638 Id
:= First_Entity
(Pack
);
4639 while Present
(Id
) loop
4641 -- Preserve use-visibility of operators that are primitive
4642 -- operators of a type that is use-visible through an active
4645 if Nkind
(Id
) = N_Defining_Operator_Symbol
4647 (Is_Primitive_Operator_In_Use
(Id
, First_Formal
(Id
))
4649 (Present
(Next_Formal
(First_Formal
(Id
)))
4651 Is_Primitive_Operator_In_Use
4652 (Id
, Next_Formal
(First_Formal
(Id
)))))
4656 Set_Is_Potentially_Use_Visible
(Id
, False);
4659 if Is_Private_Type
(Id
)
4660 and then Present
(Full_View
(Id
))
4662 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
4668 if Present
(Renamed_Object
(Pack
)) then
4669 Set_In_Use
(Renamed_Object
(Pack
), False);
4670 Set_Current_Use_Clause
(Renamed_Object
(Pack
), Empty
);
4673 if Chars
(Pack
) = Name_System
4674 and then Scope
(Pack
) = Standard_Standard
4675 and then Present_System_Aux
4677 Id
:= First_Entity
(System_Aux_Id
);
4678 while Present
(Id
) loop
4679 Set_Is_Potentially_Use_Visible
(Id
, False);
4681 if Is_Private_Type
(Id
)
4682 and then Present
(Full_View
(Id
))
4684 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
4690 Set_In_Use
(System_Aux_Id
, False);
4693 Set_Redundant_Use
(Pack_Name
, False);
4697 if Present
(Hidden_By_Use_Clause
(N
)) then
4698 Elmt
:= First_Elmt
(Hidden_By_Use_Clause
(N
));
4699 while Present
(Elmt
) loop
4701 E
: constant Entity_Id
:= Node
(Elmt
);
4704 -- Reset either Use_Visibility or Direct_Visibility, depending
4705 -- on how the entity was hidden by the use clause.
4707 if In_Use
(Scope
(E
))
4708 and then Used_As_Generic_Actual
(Scope
(E
))
4710 Set_Is_Potentially_Use_Visible
(Node
(Elmt
));
4712 Set_Is_Immediately_Visible
(Node
(Elmt
));
4719 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
4721 end End_Use_Package
;
4727 procedure End_Use_Type
(N
: Node_Id
) is
4732 -- Start of processing for End_Use_Type
4735 Id
:= Subtype_Mark
(N
);
4737 -- A call to Rtsfind may occur while analyzing a use_type_clause, in
4738 -- which case the type marks are not resolved yet, so guard against that
4741 if Is_Entity_Name
(Id
) and then Present
(Entity
(Id
)) then
4744 if T
= Any_Type
or else From_Limited_With
(T
) then
4747 -- Note that the use_type_clause may mention a subtype of the type
4748 -- whose primitive operations have been made visible. Here as
4749 -- elsewhere, it is the base type that matters for visibility.
4751 elsif In_Open_Scopes
(Scope
(Base_Type
(T
))) then
4754 elsif not Redundant_Use
(Id
) then
4755 Set_In_Use
(T
, False);
4756 Set_In_Use
(Base_Type
(T
), False);
4757 Set_Current_Use_Clause
(T
, Empty
);
4758 Set_Current_Use_Clause
(Base_Type
(T
), Empty
);
4762 if Is_Empty_Elmt_List
(Used_Operations
(N
)) then
4766 Elmt
:= First_Elmt
(Used_Operations
(N
));
4767 while Present
(Elmt
) loop
4768 Set_Is_Potentially_Use_Visible
(Node
(Elmt
), False);
4774 --------------------
4775 -- Entity_Of_Unit --
4776 --------------------
4778 function Entity_Of_Unit
(U
: Node_Id
) return Entity_Id
is
4780 if Nkind
(U
) = N_Package_Instantiation
and then Analyzed
(U
) then
4781 return Defining_Entity
(Instance_Spec
(U
));
4783 return Defining_Entity
(U
);
4787 ----------------------
4788 -- Find_Direct_Name --
4789 ----------------------
4791 procedure Find_Direct_Name
(N
: Node_Id
) is
4796 Homonyms
: Entity_Id
;
4797 -- Saves start of homonym chain
4799 Inst
: Entity_Id
:= Empty
;
4800 -- Enclosing instance, if any
4802 Nvis_Entity
: Boolean;
4803 -- Set True to indicate that there is at least one entity on the homonym
4804 -- chain which, while not visible, is visible enough from the user point
4805 -- of view to warrant an error message of "not visible" rather than
4808 Nvis_Is_Private_Subprg
: Boolean := False;
4809 -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais
4810 -- effect concerning library subprograms has been detected. Used to
4811 -- generate the precise error message.
4813 function From_Actual_Package
(E
: Entity_Id
) return Boolean;
4814 -- Returns true if the entity is an actual for a package that is itself
4815 -- an actual for a formal package of the current instance. Such an
4816 -- entity requires special handling because it may be use-visible but
4817 -- hides directly visible entities defined outside the instance, because
4818 -- the corresponding formal did so in the generic.
4820 function Is_Actual_Parameter
return Boolean;
4821 -- This function checks if the node N is an identifier that is an actual
4822 -- parameter of a procedure call. If so it returns True, otherwise it
4823 -- return False. The reason for this check is that at this stage we do
4824 -- not know what procedure is being called if the procedure might be
4825 -- overloaded, so it is premature to go setting referenced flags or
4826 -- making calls to Generate_Reference. We will wait till Resolve_Actuals
4827 -- for that processing
4829 function Known_But_Invisible
(E
: Entity_Id
) return Boolean;
4830 -- This function determines whether a reference to the entity E, which
4831 -- is not visible, can reasonably be considered to be known to the
4832 -- writer of the reference. This is a heuristic test, used only for
4833 -- the purposes of figuring out whether we prefer to complain that an
4834 -- entity is undefined or invisible (and identify the declaration of
4835 -- the invisible entity in the latter case). The point here is that we
4836 -- don't want to complain that something is invisible and then point to
4837 -- something entirely mysterious to the writer.
4839 procedure Nvis_Messages
;
4840 -- Called if there are no visible entries for N, but there is at least
4841 -- one non-directly visible, or hidden declaration. This procedure
4842 -- outputs an appropriate set of error messages.
4844 procedure Undefined
(Nvis
: Boolean);
4845 -- This function is called if the current node has no corresponding
4846 -- visible entity or entities. The value set in Msg indicates whether
4847 -- an error message was generated (multiple error messages for the
4848 -- same variable are generally suppressed, see body for details).
4849 -- Msg is True if an error message was generated, False if not. This
4850 -- value is used by the caller to determine whether or not to output
4851 -- additional messages where appropriate. The parameter is set False
4852 -- to get the message "X is undefined", and True to get the message
4853 -- "X is not visible".
4855 -------------------------
4856 -- From_Actual_Package --
4857 -------------------------
4859 function From_Actual_Package
(E
: Entity_Id
) return Boolean is
4860 Scop
: constant Entity_Id
:= Scope
(E
);
4861 -- Declared scope of candidate entity
4863 function Declared_In_Actual
(Pack
: Entity_Id
) return Boolean;
4864 -- Recursive function that does the work and examines actuals of
4865 -- actual packages of current instance.
4867 ------------------------
4868 -- Declared_In_Actual --
4869 ------------------------
4871 function Declared_In_Actual
(Pack
: Entity_Id
) return Boolean is
4875 if No
(Associated_Formal_Package
(Pack
)) then
4879 Act
:= First_Entity
(Pack
);
4880 while Present
(Act
) loop
4881 if Renamed_Object
(Pack
) = Scop
then
4884 -- Check for end of list of actuals
4886 elsif Ekind
(Act
) = E_Package
4887 and then Renamed_Object
(Act
) = Pack
4891 elsif Ekind
(Act
) = E_Package
4892 and then Declared_In_Actual
(Act
)
4902 end Declared_In_Actual
;
4908 -- Start of processing for From_Actual_Package
4911 if not In_Instance
then
4915 Inst
:= Current_Scope
;
4916 while Present
(Inst
)
4917 and then Ekind
(Inst
) /= E_Package
4918 and then not Is_Generic_Instance
(Inst
)
4920 Inst
:= Scope
(Inst
);
4927 Act
:= First_Entity
(Inst
);
4928 while Present
(Act
) loop
4929 if Ekind
(Act
) = E_Package
4930 and then Declared_In_Actual
(Act
)
4940 end From_Actual_Package
;
4942 -------------------------
4943 -- Is_Actual_Parameter --
4944 -------------------------
4946 function Is_Actual_Parameter
return Boolean is
4949 Nkind
(N
) = N_Identifier
4951 (Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
4953 (Nkind
(Parent
(N
)) = N_Parameter_Association
4954 and then N
= Explicit_Actual_Parameter
(Parent
(N
))
4955 and then Nkind
(Parent
(Parent
(N
))) =
4956 N_Procedure_Call_Statement
));
4957 end Is_Actual_Parameter
;
4959 -------------------------
4960 -- Known_But_Invisible --
4961 -------------------------
4963 function Known_But_Invisible
(E
: Entity_Id
) return Boolean is
4964 Fname
: File_Name_Type
;
4967 -- Entities in Standard are always considered to be known
4969 if Sloc
(E
) <= Standard_Location
then
4972 -- An entity that does not come from source is always considered
4973 -- to be unknown, since it is an artifact of code expansion.
4975 elsif not Comes_From_Source
(E
) then
4978 -- In gnat internal mode, we consider all entities known. The
4979 -- historical reason behind this discrepancy is not known??? But the
4980 -- only effect is to modify the error message given, so it is not
4981 -- critical. Since it only affects the exact wording of error
4982 -- messages in illegal programs, we do not mention this as an
4983 -- effect of -gnatg, since it is not a language modification.
4985 elsif GNAT_Mode
then
4989 -- Here we have an entity that is not from package Standard, and
4990 -- which comes from Source. See if it comes from an internal file.
4992 Fname
:= Unit_File_Name
(Get_Source_Unit
(E
));
4994 -- Case of from internal file
4996 if In_Internal_Unit
(E
) then
4998 -- Private part entities in internal files are never considered
4999 -- to be known to the writer of normal application code.
5001 if Is_Hidden
(E
) then
5005 -- Entities from System packages other than System and
5006 -- System.Storage_Elements are not considered to be known.
5007 -- System.Auxxxx files are also considered known to the user.
5009 -- Should refine this at some point to generally distinguish
5010 -- between known and unknown internal files ???
5012 Get_Name_String
(Fname
);
5017 Name_Buffer
(1 .. 2) /= "s-"
5019 Name_Buffer
(3 .. 8) = "stoele"
5021 Name_Buffer
(3 .. 5) = "aux";
5023 -- If not an internal file, then entity is definitely known, even if
5024 -- it is in a private part (the message generated will note that it
5025 -- is in a private part).
5030 end Known_But_Invisible
;
5036 procedure Nvis_Messages
is
5037 Comp_Unit
: Node_Id
;
5039 Found
: Boolean := False;
5040 Hidden
: Boolean := False;
5044 -- Ada 2005 (AI-262): Generate a precise error concerning the
5045 -- Beaujolais effect that was previously detected
5047 if Nvis_Is_Private_Subprg
then
5049 pragma Assert
(Nkind
(E2
) = N_Defining_Identifier
5050 and then Ekind
(E2
) = E_Function
5051 and then Scope
(E2
) = Standard_Standard
5052 and then Has_Private_With
(E2
));
5054 -- Find the sloc corresponding to the private with'ed unit
5056 Comp_Unit
:= Cunit
(Current_Sem_Unit
);
5057 Error_Msg_Sloc
:= No_Location
;
5059 Item
:= First
(Context_Items
(Comp_Unit
));
5060 while Present
(Item
) loop
5061 if Nkind
(Item
) = N_With_Clause
5062 and then Private_Present
(Item
)
5063 and then Entity
(Name
(Item
)) = E2
5065 Error_Msg_Sloc
:= Sloc
(Item
);
5072 pragma Assert
(Error_Msg_Sloc
/= No_Location
);
5074 Error_Msg_N
("(Ada 2005): hidden by private with clause #", N
);
5078 Undefined
(Nvis
=> True);
5082 -- First loop does hidden declarations
5085 while Present
(Ent
) loop
5086 if Is_Potentially_Use_Visible
(Ent
) then
5088 Error_Msg_N
-- CODEFIX
5089 ("multiple use clauses cause hiding!", N
);
5093 Error_Msg_Sloc
:= Sloc
(Ent
);
5094 Error_Msg_N
-- CODEFIX
5095 ("hidden declaration#!", N
);
5098 Ent
:= Homonym
(Ent
);
5101 -- If we found hidden declarations, then that's enough, don't
5102 -- bother looking for non-visible declarations as well.
5108 -- Second loop does non-directly visible declarations
5111 while Present
(Ent
) loop
5112 if not Is_Potentially_Use_Visible
(Ent
) then
5114 -- Do not bother the user with unknown entities
5116 if not Known_But_Invisible
(Ent
) then
5120 Error_Msg_Sloc
:= Sloc
(Ent
);
5122 -- Output message noting that there is a non-visible
5123 -- declaration, distinguishing the private part case.
5125 if Is_Hidden
(Ent
) then
5126 Error_Msg_N
("non-visible (private) declaration#!", N
);
5128 -- If the entity is declared in a generic package, it
5129 -- cannot be visible, so there is no point in adding it
5130 -- to the list of candidates if another homograph from a
5131 -- non-generic package has been seen.
5133 elsif Ekind
(Scope
(Ent
)) = E_Generic_Package
5139 Error_Msg_N
-- CODEFIX
5140 ("non-visible declaration#!", N
);
5142 if Ekind
(Scope
(Ent
)) /= E_Generic_Package
then
5146 if Is_Compilation_Unit
(Ent
)
5148 Nkind
(Parent
(Parent
(N
))) = N_Use_Package_Clause
5150 Error_Msg_Qual_Level
:= 99;
5151 Error_Msg_NE
-- CODEFIX
5152 ("\\missing `WITH &;`", N
, Ent
);
5153 Error_Msg_Qual_Level
:= 0;
5156 if Ekind
(Ent
) = E_Discriminant
5157 and then Present
(Corresponding_Discriminant
(Ent
))
5158 and then Scope
(Corresponding_Discriminant
(Ent
)) =
5162 ("inherited discriminant not allowed here" &
5163 " (RM 3.8 (12), 3.8.1 (6))!", N
);
5167 -- Set entity and its containing package as referenced. We
5168 -- can't be sure of this, but this seems a better choice
5169 -- to avoid unused entity messages.
5171 if Comes_From_Source
(Ent
) then
5172 Set_Referenced
(Ent
);
5173 Set_Referenced
(Cunit_Entity
(Get_Source_Unit
(Ent
)));
5178 Ent
:= Homonym
(Ent
);
5187 procedure Undefined
(Nvis
: Boolean) is
5188 Emsg
: Error_Msg_Id
;
5191 -- We should never find an undefined internal name. If we do, then
5192 -- see if we have previous errors. If so, ignore on the grounds that
5193 -- it is probably a cascaded message (e.g. a block label from a badly
5194 -- formed block). If no previous errors, then we have a real internal
5195 -- error of some kind so raise an exception.
5197 if Is_Internal_Name
(Chars
(N
)) then
5198 if Total_Errors_Detected
/= 0 then
5201 raise Program_Error
;
5205 -- A very specialized error check, if the undefined variable is
5206 -- a case tag, and the case type is an enumeration type, check
5207 -- for a possible misspelling, and if so, modify the identifier
5209 -- Named aggregate should also be handled similarly ???
5211 if Nkind
(N
) = N_Identifier
5212 and then Nkind
(Parent
(N
)) = N_Case_Statement_Alternative
5215 Case_Stm
: constant Node_Id
:= Parent
(Parent
(N
));
5216 Case_Typ
: constant Entity_Id
:= Etype
(Expression
(Case_Stm
));
5221 if Is_Enumeration_Type
(Case_Typ
)
5222 and then not Is_Standard_Character_Type
(Case_Typ
)
5224 Lit
:= First_Literal
(Case_Typ
);
5225 Get_Name_String
(Chars
(Lit
));
5227 if Chars
(Lit
) /= Chars
(N
)
5228 and then Is_Bad_Spelling_Of
(Chars
(N
), Chars
(Lit
))
5230 Error_Msg_Node_2
:= Lit
;
5231 Error_Msg_N
-- CODEFIX
5232 ("& is undefined, assume misspelling of &", N
);
5233 Rewrite
(N
, New_Occurrence_Of
(Lit
, Sloc
(N
)));
5237 Lit
:= Next_Literal
(Lit
);
5242 -- Normal processing
5244 Set_Entity
(N
, Any_Id
);
5245 Set_Etype
(N
, Any_Type
);
5247 -- We use the table Urefs to keep track of entities for which we
5248 -- have issued errors for undefined references. Multiple errors
5249 -- for a single name are normally suppressed, however we modify
5250 -- the error message to alert the programmer to this effect.
5252 for J
in Urefs
.First
.. Urefs
.Last
loop
5253 if Chars
(N
) = Chars
(Urefs
.Table
(J
).Node
) then
5254 if Urefs
.Table
(J
).Err
/= No_Error_Msg
5255 and then Sloc
(N
) /= Urefs
.Table
(J
).Loc
5257 Error_Msg_Node_1
:= Urefs
.Table
(J
).Node
;
5259 if Urefs
.Table
(J
).Nvis
then
5260 Change_Error_Text
(Urefs
.Table
(J
).Err
,
5261 "& is not visible (more references follow)");
5263 Change_Error_Text
(Urefs
.Table
(J
).Err
,
5264 "& is undefined (more references follow)");
5267 Urefs
.Table
(J
).Err
:= No_Error_Msg
;
5270 -- Although we will set Msg False, and thus suppress the
5271 -- message, we also set Error_Posted True, to avoid any
5272 -- cascaded messages resulting from the undefined reference.
5275 Set_Error_Posted
(N
, True);
5280 -- If entry not found, this is first undefined occurrence
5283 Error_Msg_N
("& is not visible!", N
);
5287 Error_Msg_N
("& is undefined!", N
);
5290 -- A very bizarre special check, if the undefined identifier
5291 -- is put or put_line, then add a special error message (since
5292 -- this is a very common error for beginners to make).
5294 if Nam_In
(Chars
(N
), Name_Put
, Name_Put_Line
) then
5295 Error_Msg_N
-- CODEFIX
5296 ("\\possible missing `WITH Ada.Text_'I'O; " &
5297 "USE Ada.Text_'I'O`!", N
);
5299 -- Another special check if N is the prefix of a selected
5300 -- component which is a known unit, add message complaining
5301 -- about missing with for this unit.
5303 elsif Nkind
(Parent
(N
)) = N_Selected_Component
5304 and then N
= Prefix
(Parent
(N
))
5305 and then Is_Known_Unit
(Parent
(N
))
5307 Error_Msg_Node_2
:= Selector_Name
(Parent
(N
));
5308 Error_Msg_N
-- CODEFIX
5309 ("\\missing `WITH &.&;`", Prefix
(Parent
(N
)));
5312 -- Now check for possible misspellings
5316 Ematch
: Entity_Id
:= Empty
;
5318 Last_Name_Id
: constant Name_Id
:=
5319 Name_Id
(Nat
(First_Name_Id
) +
5320 Name_Entries_Count
- 1);
5323 for Nam
in First_Name_Id
.. Last_Name_Id
loop
5324 E
:= Get_Name_Entity_Id
(Nam
);
5327 and then (Is_Immediately_Visible
(E
)
5329 Is_Potentially_Use_Visible
(E
))
5331 if Is_Bad_Spelling_Of
(Chars
(N
), Nam
) then
5338 if Present
(Ematch
) then
5339 Error_Msg_NE
-- CODEFIX
5340 ("\possible misspelling of&", N
, Ematch
);
5345 -- Make entry in undefined references table unless the full errors
5346 -- switch is set, in which case by refraining from generating the
5347 -- table entry, we guarantee that we get an error message for every
5348 -- undefined reference. The entry is not added if we are ignoring
5351 if not All_Errors_Mode
and then Ignore_Errors_Enable
= 0 then
5364 Nested_Inst
: Entity_Id
:= Empty
;
5365 -- The entity of a nested instance which appears within Inst (if any)
5367 -- Start of processing for Find_Direct_Name
5370 -- If the entity pointer is already set, this is an internal node, or
5371 -- a node that is analyzed more than once, after a tree modification.
5372 -- In such a case there is no resolution to perform, just set the type.
5374 if Present
(Entity
(N
)) then
5375 if Is_Type
(Entity
(N
)) then
5376 Set_Etype
(N
, Entity
(N
));
5380 Entyp
: constant Entity_Id
:= Etype
(Entity
(N
));
5383 -- One special case here. If the Etype field is already set,
5384 -- and references the packed array type corresponding to the
5385 -- etype of the referenced entity, then leave it alone. This
5386 -- happens for trees generated from Exp_Pakd, where expressions
5387 -- can be deliberately "mis-typed" to the packed array type.
5389 if Is_Array_Type
(Entyp
)
5390 and then Is_Packed
(Entyp
)
5391 and then Present
(Etype
(N
))
5392 and then Etype
(N
) = Packed_Array_Impl_Type
(Entyp
)
5396 -- If not that special case, then just reset the Etype
5399 Set_Etype
(N
, Etype
(Entity
(N
)));
5404 -- Although the marking of use clauses happens at the end of
5405 -- Find_Direct_Name, a certain case where a generic actual satisfies
5406 -- a use clause must be checked here due to how the generic machinery
5407 -- handles the analysis of said actuals.
5410 and then Nkind
(Parent
(N
)) = N_Generic_Association
5412 Mark_Use_Clauses
(Entity
(N
));
5418 -- Preserve relevant elaboration-related attributes of the context which
5419 -- are no longer available or very expensive to recompute once analysis,
5420 -- resolution, and expansion are over.
5422 if Nkind
(N
) = N_Identifier
then
5423 Mark_Elaboration_Attributes
5428 -- Here if Entity pointer was not set, we need full visibility analysis
5429 -- First we generate debugging output if the debug E flag is set.
5431 if Debug_Flag_E
then
5432 Write_Str
("Looking for ");
5433 Write_Name
(Chars
(N
));
5437 Homonyms
:= Current_Entity
(N
);
5438 Nvis_Entity
:= False;
5441 while Present
(E
) loop
5443 -- If entity is immediately visible or potentially use visible, then
5444 -- process the entity and we are done.
5446 if Is_Immediately_Visible
(E
) then
5447 goto Immediately_Visible_Entity
;
5449 elsif Is_Potentially_Use_Visible
(E
) then
5450 goto Potentially_Use_Visible_Entity
;
5452 -- Note if a known but invisible entity encountered
5454 elsif Known_But_Invisible
(E
) then
5455 Nvis_Entity
:= True;
5458 -- Move to next entity in chain and continue search
5463 -- If no entries on homonym chain that were potentially visible,
5464 -- and no entities reasonably considered as non-visible, then
5465 -- we have a plain undefined reference, with no additional
5466 -- explanation required.
5468 if not Nvis_Entity
then
5469 Undefined
(Nvis
=> False);
5471 -- Otherwise there is at least one entry on the homonym chain that
5472 -- is reasonably considered as being known and non-visible.
5480 -- Processing for a potentially use visible entry found. We must search
5481 -- the rest of the homonym chain for two reasons. First, if there is a
5482 -- directly visible entry, then none of the potentially use-visible
5483 -- entities are directly visible (RM 8.4(10)). Second, we need to check
5484 -- for the case of multiple potentially use-visible entries hiding one
5485 -- another and as a result being non-directly visible (RM 8.4(11)).
5487 <<Potentially_Use_Visible_Entity
>> declare
5488 Only_One_Visible
: Boolean := True;
5489 All_Overloadable
: Boolean := Is_Overloadable
(E
);
5493 while Present
(E2
) loop
5494 if Is_Immediately_Visible
(E2
) then
5496 -- If the use-visible entity comes from the actual for a
5497 -- formal package, it hides a directly visible entity from
5498 -- outside the instance.
5500 if From_Actual_Package
(E
)
5501 and then Scope_Depth
(E2
) < Scope_Depth
(Inst
)
5506 goto Immediately_Visible_Entity
;
5509 elsif Is_Potentially_Use_Visible
(E2
) then
5510 Only_One_Visible
:= False;
5511 All_Overloadable
:= All_Overloadable
and Is_Overloadable
(E2
);
5513 -- Ada 2005 (AI-262): Protect against a form of Beaujolais effect
5514 -- that can occur in private_with clauses. Example:
5517 -- private with B; package A is
5518 -- package C is function B return Integer;
5520 -- V1 : Integer := B;
5521 -- private function B return Integer;
5522 -- V2 : Integer := B;
5525 -- V1 resolves to A.B, but V2 resolves to library unit B
5527 elsif Ekind
(E2
) = E_Function
5528 and then Scope
(E2
) = Standard_Standard
5529 and then Has_Private_With
(E2
)
5531 Only_One_Visible
:= False;
5532 All_Overloadable
:= False;
5533 Nvis_Is_Private_Subprg
:= True;
5540 -- On falling through this loop, we have checked that there are no
5541 -- immediately visible entities. Only_One_Visible is set if exactly
5542 -- one potentially use visible entity exists. All_Overloadable is
5543 -- set if all the potentially use visible entities are overloadable.
5544 -- The condition for legality is that either there is one potentially
5545 -- use visible entity, or if there is more than one, then all of them
5546 -- are overloadable.
5548 if Only_One_Visible
or All_Overloadable
then
5551 -- If there is more than one potentially use-visible entity and at
5552 -- least one of them non-overloadable, we have an error (RM 8.4(11)).
5553 -- Note that E points to the first such entity on the homonym list.
5556 -- If one of the entities is declared in an actual package, it
5557 -- was visible in the generic, and takes precedence over other
5558 -- entities that are potentially use-visible. The same applies
5559 -- if the entity is declared in a local instantiation of the
5560 -- current instance.
5564 -- Find the current instance
5566 Inst
:= Current_Scope
;
5567 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
5568 if Is_Generic_Instance
(Inst
) then
5572 Inst
:= Scope
(Inst
);
5575 -- Reexamine the candidate entities, giving priority to those
5576 -- that were visible within the generic.
5579 while Present
(E2
) loop
5580 Nested_Inst
:= Nearest_Enclosing_Instance
(E2
);
5582 -- The entity is declared within an actual package, or in a
5583 -- nested instance. The ">=" accounts for the case where the
5584 -- current instance and the nested instance are the same.
5586 if From_Actual_Package
(E2
)
5587 or else (Present
(Nested_Inst
)
5588 and then Scope_Depth
(Nested_Inst
) >=
5601 elsif Is_Predefined_Unit
(Current_Sem_Unit
) then
5602 -- A use clause in the body of a system file creates conflict
5603 -- with some entity in a user scope, while rtsfind is active.
5604 -- Keep only the entity coming from another predefined unit.
5607 while Present
(E2
) loop
5608 if In_Predefined_Unit
(E2
) then
5616 -- Entity must exist because predefined unit is correct
5618 raise Program_Error
;
5627 -- Come here with E set to the first immediately visible entity on
5628 -- the homonym chain. This is the one we want unless there is another
5629 -- immediately visible entity further on in the chain for an inner
5630 -- scope (RM 8.3(8)).
5632 <<Immediately_Visible_Entity
>> declare
5637 -- Find scope level of initial entity. When compiling through
5638 -- Rtsfind, the previous context is not completely invisible, and
5639 -- an outer entity may appear on the chain, whose scope is below
5640 -- the entry for Standard that delimits the current scope stack.
5641 -- Indicate that the level for this spurious entry is outside of
5642 -- the current scope stack.
5644 Level
:= Scope_Stack
.Last
;
5646 Scop
:= Scope_Stack
.Table
(Level
).Entity
;
5647 exit when Scop
= Scope
(E
);
5649 exit when Scop
= Standard_Standard
;
5652 -- Now search remainder of homonym chain for more inner entry
5653 -- If the entity is Standard itself, it has no scope, and we
5654 -- compare it with the stack entry directly.
5657 while Present
(E2
) loop
5658 if Is_Immediately_Visible
(E2
) then
5660 -- If a generic package contains a local declaration that
5661 -- has the same name as the generic, there may be a visibility
5662 -- conflict in an instance, where the local declaration must
5663 -- also hide the name of the corresponding package renaming.
5664 -- We check explicitly for a package declared by a renaming,
5665 -- whose renamed entity is an instance that is on the scope
5666 -- stack, and that contains a homonym in the same scope. Once
5667 -- we have found it, we know that the package renaming is not
5668 -- immediately visible, and that the identifier denotes the
5669 -- other entity (and its homonyms if overloaded).
5671 if Scope
(E
) = Scope
(E2
)
5672 and then Ekind
(E
) = E_Package
5673 and then Present
(Renamed_Object
(E
))
5674 and then Is_Generic_Instance
(Renamed_Object
(E
))
5675 and then In_Open_Scopes
(Renamed_Object
(E
))
5676 and then Comes_From_Source
(N
)
5678 Set_Is_Immediately_Visible
(E
, False);
5682 for J
in Level
+ 1 .. Scope_Stack
.Last
loop
5683 if Scope_Stack
.Table
(J
).Entity
= Scope
(E2
)
5684 or else Scope_Stack
.Table
(J
).Entity
= E2
5697 -- At the end of that loop, E is the innermost immediately
5698 -- visible entity, so we are all set.
5701 -- Come here with entity found, and stored in E
5705 -- Check violation of No_Wide_Characters restriction
5707 Check_Wide_Character_Restriction
(E
, N
);
5709 -- When distribution features are available (Get_PCS_Name /=
5710 -- Name_No_DSA), a remote access-to-subprogram type is converted
5711 -- into a record type holding whatever information is needed to
5712 -- perform a remote call on an RCI subprogram. In that case we
5713 -- rewrite any occurrence of the RAS type into the equivalent record
5714 -- type here. 'Access attribute references and RAS dereferences are
5715 -- then implemented using specific TSSs. However when distribution is
5716 -- not available (case of Get_PCS_Name = Name_No_DSA), we bypass the
5717 -- generation of these TSSs, and we must keep the RAS type in its
5718 -- original access-to-subprogram form (since all calls through a
5719 -- value of such type will be local anyway in the absence of a PCS).
5721 if Comes_From_Source
(N
)
5722 and then Is_Remote_Access_To_Subprogram_Type
(E
)
5723 and then Ekind
(E
) = E_Access_Subprogram_Type
5724 and then Expander_Active
5725 and then Get_PCS_Name
/= Name_No_DSA
5727 Rewrite
(N
, New_Occurrence_Of
(Equivalent_Type
(E
), Sloc
(N
)));
5731 -- Set the entity. Note that the reason we call Set_Entity for the
5732 -- overloadable case, as opposed to Set_Entity_With_Checks is
5733 -- that in the overloaded case, the initial call can set the wrong
5734 -- homonym. The call that sets the right homonym is in Sem_Res and
5735 -- that call does use Set_Entity_With_Checks, so we don't miss
5738 if Is_Overloadable
(E
) then
5741 Set_Entity_With_Checks
(N
, E
);
5747 Set_Etype
(N
, Get_Full_View
(Etype
(E
)));
5750 if Debug_Flag_E
then
5751 Write_Str
(" found ");
5752 Write_Entity_Info
(E
, " ");
5755 -- If the Ekind of the entity is Void, it means that all homonyms
5756 -- are hidden from all visibility (RM 8.3(5,14-20)). However, this
5757 -- test is skipped if the current scope is a record and the name is
5758 -- a pragma argument expression (case of Atomic and Volatile pragmas
5759 -- and possibly other similar pragmas added later, which are allowed
5760 -- to reference components in the current record).
5762 if Ekind
(E
) = E_Void
5764 (not Is_Record_Type
(Current_Scope
)
5765 or else Nkind
(Parent
(N
)) /= N_Pragma_Argument_Association
)
5767 Premature_Usage
(N
);
5769 -- If the entity is overloadable, collect all interpretations of the
5770 -- name for subsequent overload resolution. We optimize a bit here to
5771 -- do this only if we have an overloadable entity that is not on its
5772 -- own on the homonym chain.
5774 elsif Is_Overloadable
(E
)
5775 and then (Present
(Homonym
(E
)) or else Current_Entity
(N
) /= E
)
5777 Collect_Interps
(N
);
5779 -- If no homonyms were visible, the entity is unambiguous
5781 if not Is_Overloaded
(N
) then
5782 if not Is_Actual_Parameter
then
5783 Generate_Reference
(E
, N
);
5787 -- Case of non-overloadable entity, set the entity providing that
5788 -- we do not have the case of a discriminant reference within a
5789 -- default expression. Such references are replaced with the
5790 -- corresponding discriminal, which is the formal corresponding to
5791 -- to the discriminant in the initialization procedure.
5794 -- Entity is unambiguous, indicate that it is referenced here
5796 -- For a renaming of an object, always generate simple reference,
5797 -- we don't try to keep track of assignments in this case, except
5798 -- in SPARK mode where renamings are traversed for generating
5799 -- local effects of subprograms.
5802 and then Present
(Renamed_Object
(E
))
5803 and then not GNATprove_Mode
5805 Generate_Reference
(E
, N
);
5807 -- If the renamed entity is a private protected component,
5808 -- reference the original component as well. This needs to be
5809 -- done because the private renamings are installed before any
5810 -- analysis has occurred. Reference to a private component will
5811 -- resolve to the renaming and the original component will be
5812 -- left unreferenced, hence the following.
5814 if Is_Prival
(E
) then
5815 Generate_Reference
(Prival_Link
(E
), N
);
5818 -- One odd case is that we do not want to set the Referenced flag
5819 -- if the entity is a label, and the identifier is the label in
5820 -- the source, since this is not a reference from the point of
5821 -- view of the user.
5823 elsif Nkind
(Parent
(N
)) = N_Label
then
5825 R
: constant Boolean := Referenced
(E
);
5828 -- Generate reference unless this is an actual parameter
5829 -- (see comment below)
5831 if Is_Actual_Parameter
then
5832 Generate_Reference
(E
, N
);
5833 Set_Referenced
(E
, R
);
5837 -- Normal case, not a label: generate reference
5840 if not Is_Actual_Parameter
then
5842 -- Package or generic package is always a simple reference
5844 if Ekind_In
(E
, E_Package
, E_Generic_Package
) then
5845 Generate_Reference
(E
, N
, 'r');
5847 -- Else see if we have a left hand side
5852 Generate_Reference
(E
, N
, 'm');
5855 Generate_Reference
(E
, N
, 'r');
5857 -- If we don't know now, generate reference later
5860 Deferred_References
.Append
((E
, N
));
5866 Set_Entity_Or_Discriminal
(N
, E
);
5868 -- The name may designate a generalized reference, in which case
5869 -- the dereference interpretation will be included. Context is
5870 -- one in which a name is legal.
5872 if Ada_Version
>= Ada_2012
5874 (Nkind
(Parent
(N
)) in N_Subexpr
5875 or else Nkind_In
(Parent
(N
), N_Assignment_Statement
,
5876 N_Object_Declaration
,
5877 N_Parameter_Association
))
5879 Check_Implicit_Dereference
(N
, Etype
(E
));
5884 -- Mark relevant use-type and use-package clauses as effective if the
5885 -- node in question is not overloaded and therefore does not require
5888 -- Note: Generic actual subprograms do not follow the normal resolution
5889 -- path, so ignore the fact that they are overloaded and mark them
5892 if Nkind
(N
) not in N_Subexpr
or else not Is_Overloaded
(N
) then
5893 Mark_Use_Clauses
(N
);
5896 -- Come here with entity set
5899 Check_Restriction_No_Use_Of_Entity
(N
);
5901 -- Save the scenario for later examination by the ABE Processing phase
5903 Record_Elaboration_Scenario
(N
);
5904 end Find_Direct_Name
;
5906 ------------------------
5907 -- Find_Expanded_Name --
5908 ------------------------
5910 -- This routine searches the homonym chain of the entity until it finds
5911 -- an entity declared in the scope denoted by the prefix. If the entity
5912 -- is private, it may nevertheless be immediately visible, if we are in
5913 -- the scope of its declaration.
5915 procedure Find_Expanded_Name
(N
: Node_Id
) is
5916 function In_Abstract_View_Pragma
(Nod
: Node_Id
) return Boolean;
5917 -- Determine whether expanded name Nod appears within a pragma which is
5918 -- a suitable context for an abstract view of a state or variable. The
5919 -- following pragmas fall in this category:
5926 -- In addition, pragma Abstract_State is also considered suitable even
5927 -- though it is an illegal context for an abstract view as this allows
5928 -- for proper resolution of abstract views of variables. This illegal
5929 -- context is later flagged in the analysis of indicator Part_Of.
5931 -----------------------------
5932 -- In_Abstract_View_Pragma --
5933 -----------------------------
5935 function In_Abstract_View_Pragma
(Nod
: Node_Id
) return Boolean is
5939 -- Climb the parent chain looking for a pragma
5942 while Present
(Par
) loop
5943 if Nkind
(Par
) = N_Pragma
then
5944 if Nam_In
(Pragma_Name_Unmapped
(Par
),
5945 Name_Abstract_State
,
5949 Name_Refined_Depends
,
5950 Name_Refined_Global
)
5954 -- Otherwise the pragma is not a legal context for an abstract
5961 -- Prevent the search from going too far
5963 elsif Is_Body_Or_Package_Declaration
(Par
) then
5967 Par
:= Parent
(Par
);
5971 end In_Abstract_View_Pragma
;
5975 Selector
: constant Node_Id
:= Selector_Name
(N
);
5976 Candidate
: Entity_Id
:= Empty
;
5980 -- Start of processing for Find_Expanded_Name
5983 P_Name
:= Entity
(Prefix
(N
));
5985 -- If the prefix is a renamed package, look for the entity in the
5986 -- original package.
5988 if Ekind
(P_Name
) = E_Package
5989 and then Present
(Renamed_Object
(P_Name
))
5991 P_Name
:= Renamed_Object
(P_Name
);
5993 -- Rewrite node with entity field pointing to renamed object
5995 Rewrite
(Prefix
(N
), New_Copy
(Prefix
(N
)));
5996 Set_Entity
(Prefix
(N
), P_Name
);
5998 -- If the prefix is an object of a concurrent type, look for
5999 -- the entity in the associated task or protected type.
6001 elsif Is_Concurrent_Type
(Etype
(P_Name
)) then
6002 P_Name
:= Etype
(P_Name
);
6005 Id
:= Current_Entity
(Selector
);
6008 Is_New_Candidate
: Boolean;
6011 while Present
(Id
) loop
6012 if Scope
(Id
) = P_Name
then
6014 Is_New_Candidate
:= True;
6016 -- Handle abstract views of states and variables. These are
6017 -- acceptable candidates only when the reference to the view
6018 -- appears in certain pragmas.
6020 if Ekind
(Id
) = E_Abstract_State
6021 and then From_Limited_With
(Id
)
6022 and then Present
(Non_Limited_View
(Id
))
6024 if In_Abstract_View_Pragma
(N
) then
6025 Candidate
:= Non_Limited_View
(Id
);
6026 Is_New_Candidate
:= True;
6028 -- Hide the candidate because it is not used in a proper
6033 Is_New_Candidate
:= False;
6037 -- Ada 2005 (AI-217): Handle shadow entities associated with
6038 -- types declared in limited-withed nested packages. We don't need
6039 -- to handle E_Incomplete_Subtype entities because the entities
6040 -- in the limited view are always E_Incomplete_Type and
6041 -- E_Class_Wide_Type entities (see Build_Limited_Views).
6043 -- Regarding the expression used to evaluate the scope, it
6044 -- is important to note that the limited view also has shadow
6045 -- entities associated nested packages. For this reason the
6046 -- correct scope of the entity is the scope of the real entity.
6047 -- The non-limited view may itself be incomplete, in which case
6048 -- get the full view if available.
6050 elsif Ekind_In
(Id
, E_Incomplete_Type
, E_Class_Wide_Type
)
6051 and then From_Limited_With
(Id
)
6052 and then Present
(Non_Limited_View
(Id
))
6053 and then Scope
(Non_Limited_View
(Id
)) = P_Name
6055 Candidate
:= Get_Full_View
(Non_Limited_View
(Id
));
6056 Is_New_Candidate
:= True;
6058 -- An unusual case arises with a fully qualified name for an
6059 -- entity local to a generic child unit package, within an
6060 -- instantiation of that package. The name of the unit now
6061 -- denotes the renaming created within the instance. This is
6062 -- only relevant in an instance body, see below.
6064 elsif Is_Generic_Instance
(Scope
(Id
))
6065 and then In_Open_Scopes
(Scope
(Id
))
6066 and then In_Instance_Body
6067 and then Ekind
(Scope
(Id
)) = E_Package
6068 and then Ekind
(Id
) = E_Package
6069 and then Renamed_Entity
(Id
) = Scope
(Id
)
6070 and then Is_Immediately_Visible
(P_Name
)
6072 Is_New_Candidate
:= True;
6075 Is_New_Candidate
:= False;
6078 if Is_New_Candidate
then
6080 -- If entity is a child unit, either it is a visible child of
6081 -- the prefix, or we are in the body of a generic prefix, as
6082 -- will happen when a child unit is instantiated in the body
6083 -- of a generic parent. This is because the instance body does
6084 -- not restore the full compilation context, given that all
6085 -- non-local references have been captured.
6087 if Is_Child_Unit
(Id
) or else P_Name
= Standard_Standard
then
6088 exit when Is_Visible_Lib_Unit
(Id
)
6089 or else (Is_Child_Unit
(Id
)
6090 and then In_Open_Scopes
(Scope
(Id
))
6091 and then In_Instance_Body
);
6093 exit when not Is_Hidden
(Id
);
6096 exit when Is_Immediately_Visible
(Id
);
6104 and then Ekind_In
(P_Name
, E_Procedure
, E_Function
)
6105 and then Is_Generic_Instance
(P_Name
)
6107 -- Expanded name denotes entity in (instance of) generic subprogram.
6108 -- The entity may be in the subprogram instance, or may denote one of
6109 -- the formals, which is declared in the enclosing wrapper package.
6111 P_Name
:= Scope
(P_Name
);
6113 Id
:= Current_Entity
(Selector
);
6114 while Present
(Id
) loop
6115 exit when Scope
(Id
) = P_Name
;
6120 if No
(Id
) or else Chars
(Id
) /= Chars
(Selector
) then
6121 Set_Etype
(N
, Any_Type
);
6123 -- If we are looking for an entity defined in System, try to find it
6124 -- in the child package that may have been provided as an extension
6125 -- to System. The Extend_System pragma will have supplied the name of
6126 -- the extension, which may have to be loaded.
6128 if Chars
(P_Name
) = Name_System
6129 and then Scope
(P_Name
) = Standard_Standard
6130 and then Present
(System_Extend_Unit
)
6131 and then Present_System_Aux
(N
)
6133 Set_Entity
(Prefix
(N
), System_Aux_Id
);
6134 Find_Expanded_Name
(N
);
6137 -- There is an implicit instance of the predefined operator in
6138 -- the given scope. The operator entity is defined in Standard.
6139 -- Has_Implicit_Operator makes the node into an Expanded_Name.
6141 elsif Nkind
(Selector
) = N_Operator_Symbol
6142 and then Has_Implicit_Operator
(N
)
6146 -- If there is no literal defined in the scope denoted by the
6147 -- prefix, the literal may belong to (a type derived from)
6148 -- Standard_Character, for which we have no explicit literals.
6150 elsif Nkind
(Selector
) = N_Character_Literal
6151 and then Has_Implicit_Character_Literal
(N
)
6156 -- If the prefix is a single concurrent object, use its name in
6157 -- the error message, rather than that of the anonymous type.
6159 if Is_Concurrent_Type
(P_Name
)
6160 and then Is_Internal_Name
(Chars
(P_Name
))
6162 Error_Msg_Node_2
:= Entity
(Prefix
(N
));
6164 Error_Msg_Node_2
:= P_Name
;
6167 if P_Name
= System_Aux_Id
then
6168 P_Name
:= Scope
(P_Name
);
6169 Set_Entity
(Prefix
(N
), P_Name
);
6172 if Present
(Candidate
) then
6174 -- If we know that the unit is a child unit we can give a more
6175 -- accurate error message.
6177 if Is_Child_Unit
(Candidate
) then
6179 -- If the candidate is a private child unit and we are in
6180 -- the visible part of a public unit, specialize the error
6181 -- message. There might be a private with_clause for it,
6182 -- but it is not currently active.
6184 if Is_Private_Descendant
(Candidate
)
6185 and then Ekind
(Current_Scope
) = E_Package
6186 and then not In_Private_Part
(Current_Scope
)
6187 and then not Is_Private_Descendant
(Current_Scope
)
6190 ("private child unit& is not visible here", Selector
);
6192 -- Normal case where we have a missing with for a child unit
6195 Error_Msg_Qual_Level
:= 99;
6196 Error_Msg_NE
-- CODEFIX
6197 ("missing `WITH &;`", Selector
, Candidate
);
6198 Error_Msg_Qual_Level
:= 0;
6201 -- Here we don't know that this is a child unit
6204 Error_Msg_NE
("& is not a visible entity of&", N
, Selector
);
6208 -- Within the instantiation of a child unit, the prefix may
6209 -- denote the parent instance, but the selector has the name
6210 -- of the original child. That is to say, when A.B appears
6211 -- within an instantiation of generic child unit B, the scope
6212 -- stack includes an instance of A (P_Name) and an instance
6213 -- of B under some other name. We scan the scope to find this
6214 -- child instance, which is the desired entity.
6215 -- Note that the parent may itself be a child instance, if
6216 -- the reference is of the form A.B.C, in which case A.B has
6217 -- already been rewritten with the proper entity.
6219 if In_Open_Scopes
(P_Name
)
6220 and then Is_Generic_Instance
(P_Name
)
6223 Gen_Par
: constant Entity_Id
:=
6224 Generic_Parent
(Specification
6225 (Unit_Declaration_Node
(P_Name
)));
6226 S
: Entity_Id
:= Current_Scope
;
6230 for J
in reverse 0 .. Scope_Stack
.Last
loop
6231 S
:= Scope_Stack
.Table
(J
).Entity
;
6233 exit when S
= Standard_Standard
;
6235 if Ekind_In
(S
, E_Function
,
6240 Generic_Parent
(Specification
6241 (Unit_Declaration_Node
(S
)));
6243 -- Check that P is a generic child of the generic
6244 -- parent of the prefix.
6247 and then Chars
(P
) = Chars
(Selector
)
6248 and then Scope
(P
) = Gen_Par
6259 -- If this is a selection from Ada, System or Interfaces, then
6260 -- we assume a missing with for the corresponding package.
6262 if Is_Known_Unit
(N
) then
6263 if not Error_Posted
(N
) then
6264 Error_Msg_Node_2
:= Selector
;
6265 Error_Msg_N
-- CODEFIX
6266 ("missing `WITH &.&;`", Prefix
(N
));
6269 -- If this is a selection from a dummy package, then suppress
6270 -- the error message, of course the entity is missing if the
6271 -- package is missing.
6273 elsif Sloc
(Error_Msg_Node_2
) = No_Location
then
6276 -- Here we have the case of an undefined component
6279 -- The prefix may hide a homonym in the context that
6280 -- declares the desired entity. This error can use a
6281 -- specialized message.
6283 if In_Open_Scopes
(P_Name
) then
6285 H
: constant Entity_Id
:= Homonym
(P_Name
);
6289 and then Is_Compilation_Unit
(H
)
6291 (Is_Immediately_Visible
(H
)
6292 or else Is_Visible_Lib_Unit
(H
))
6294 Id
:= First_Entity
(H
);
6295 while Present
(Id
) loop
6296 if Chars
(Id
) = Chars
(Selector
) then
6297 Error_Msg_Qual_Level
:= 99;
6298 Error_Msg_Name_1
:= Chars
(Selector
);
6300 ("% not declared in&", N
, P_Name
);
6302 ("\use fully qualified name starting with "
6303 & "Standard to make& visible", N
, H
);
6304 Error_Msg_Qual_Level
:= 0;
6312 -- If not found, standard error message
6314 Error_Msg_NE
("& not declared in&", N
, Selector
);
6320 -- Might be worth specializing the case when the prefix
6321 -- is a limited view.
6322 -- ... not declared in limited view of...
6324 Error_Msg_NE
("& not declared in&", N
, Selector
);
6327 -- Check for misspelling of some entity in prefix
6329 Id
:= First_Entity
(P_Name
);
6330 while Present
(Id
) loop
6331 if Is_Bad_Spelling_Of
(Chars
(Id
), Chars
(Selector
))
6332 and then not Is_Internal_Name
(Chars
(Id
))
6334 Error_Msg_NE
-- CODEFIX
6335 ("possible misspelling of&", Selector
, Id
);
6342 -- Specialize the message if this may be an instantiation
6343 -- of a child unit that was not mentioned in the context.
6345 if Nkind
(Parent
(N
)) = N_Package_Instantiation
6346 and then Is_Generic_Instance
(Entity
(Prefix
(N
)))
6347 and then Is_Compilation_Unit
6348 (Generic_Parent
(Parent
(Entity
(Prefix
(N
)))))
6350 Error_Msg_Node_2
:= Selector
;
6351 Error_Msg_N
-- CODEFIX
6352 ("\missing `WITH &.&;`", Prefix
(N
));
6362 if Comes_From_Source
(N
)
6363 and then Is_Remote_Access_To_Subprogram_Type
(Id
)
6364 and then Ekind
(Id
) = E_Access_Subprogram_Type
6365 and then Present
(Equivalent_Type
(Id
))
6367 -- If we are not actually generating distribution code (i.e. the
6368 -- current PCS is the dummy non-distributed version), then the
6369 -- Equivalent_Type will be missing, and Id should be treated as
6370 -- a regular access-to-subprogram type.
6372 Id
:= Equivalent_Type
(Id
);
6373 Set_Chars
(Selector
, Chars
(Id
));
6376 -- Ada 2005 (AI-50217): Check usage of entities in limited withed units
6378 if Ekind
(P_Name
) = E_Package
and then From_Limited_With
(P_Name
) then
6379 if From_Limited_With
(Id
)
6380 or else Is_Type
(Id
)
6381 or else Ekind
(Id
) = E_Package
6386 ("limited withed package can only be used to access incomplete "
6391 if Is_Task_Type
(P_Name
)
6392 and then ((Ekind
(Id
) = E_Entry
6393 and then Nkind
(Parent
(N
)) /= N_Attribute_Reference
)
6395 (Ekind
(Id
) = E_Entry_Family
6397 Nkind
(Parent
(Parent
(N
))) /= N_Attribute_Reference
))
6399 -- If both the task type and the entry are in scope, this may still
6400 -- be the expanded name of an entry formal.
6402 if In_Open_Scopes
(Id
)
6403 and then Nkind
(Parent
(N
)) = N_Selected_Component
6408 -- It is an entry call after all, either to the current task
6409 -- (which will deadlock) or to an enclosing task.
6411 Analyze_Selected_Component
(N
);
6416 Change_Selected_Component_To_Expanded_Name
(N
);
6418 -- Preserve relevant elaboration-related attributes of the context which
6419 -- are no longer available or very expensive to recompute once analysis,
6420 -- resolution, and expansion are over.
6422 Mark_Elaboration_Attributes
6426 -- Set appropriate type
6428 if Is_Type
(Id
) then
6431 Set_Etype
(N
, Get_Full_View
(Etype
(Id
)));
6434 -- Do style check and generate reference, but skip both steps if this
6435 -- entity has homonyms, since we may not have the right homonym set yet.
6436 -- The proper homonym will be set during the resolve phase.
6438 if Has_Homonym
(Id
) then
6442 Set_Entity_Or_Discriminal
(N
, Id
);
6446 Generate_Reference
(Id
, N
, 'm');
6449 Generate_Reference
(Id
, N
, 'r');
6452 Deferred_References
.Append
((Id
, N
));
6456 -- Check for violation of No_Wide_Characters
6458 Check_Wide_Character_Restriction
(Id
, N
);
6460 -- If the Ekind of the entity is Void, it means that all homonyms are
6461 -- hidden from all visibility (RM 8.3(5,14-20)).
6463 if Ekind
(Id
) = E_Void
then
6464 Premature_Usage
(N
);
6466 elsif Is_Overloadable
(Id
) and then Present
(Homonym
(Id
)) then
6468 H
: Entity_Id
:= Homonym
(Id
);
6471 while Present
(H
) loop
6472 if Scope
(H
) = Scope
(Id
)
6473 and then (not Is_Hidden
(H
)
6474 or else Is_Immediately_Visible
(H
))
6476 Collect_Interps
(N
);
6483 -- If an extension of System is present, collect possible explicit
6484 -- overloadings declared in the extension.
6486 if Chars
(P_Name
) = Name_System
6487 and then Scope
(P_Name
) = Standard_Standard
6488 and then Present
(System_Extend_Unit
)
6489 and then Present_System_Aux
(N
)
6491 H
:= Current_Entity
(Id
);
6493 while Present
(H
) loop
6494 if Scope
(H
) = System_Aux_Id
then
6495 Add_One_Interp
(N
, H
, Etype
(H
));
6504 if Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
6505 and then Scope
(Id
) /= Standard_Standard
6507 -- In addition to user-defined operators in the given scope, there
6508 -- may be an implicit instance of the predefined operator. The
6509 -- operator (defined in Standard) is found in Has_Implicit_Operator,
6510 -- and added to the interpretations. Procedure Add_One_Interp will
6511 -- determine which hides which.
6513 if Has_Implicit_Operator
(N
) then
6518 -- If there is a single interpretation for N we can generate a
6519 -- reference to the unique entity found.
6521 if Is_Overloadable
(Id
) and then not Is_Overloaded
(N
) then
6522 Generate_Reference
(Id
, N
);
6525 -- Mark relevant use-type and use-package clauses as effective if the
6526 -- node in question is not overloaded and therefore does not require
6529 if Nkind
(N
) not in N_Subexpr
or else not Is_Overloaded
(N
) then
6530 Mark_Use_Clauses
(N
);
6533 Check_Restriction_No_Use_Of_Entity
(N
);
6535 -- Save the scenario for later examination by the ABE Processing phase
6537 Record_Elaboration_Scenario
(N
);
6538 end Find_Expanded_Name
;
6540 --------------------
6541 -- Find_Most_Prev --
6542 --------------------
6544 function Find_Most_Prev
(Use_Clause
: Node_Id
) return Node_Id
is
6548 -- Loop through the Prev_Use_Clause chain
6551 while Present
(Prev_Use_Clause
(Curr
)) loop
6552 Curr
:= Prev_Use_Clause
(Curr
);
6558 -------------------------
6559 -- Find_Renamed_Entity --
6560 -------------------------
6562 function Find_Renamed_Entity
6566 Is_Actual
: Boolean := False) return Entity_Id
6569 I1
: Interp_Index
:= 0; -- Suppress junk warnings
6575 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean;
6576 -- If the renamed entity is an implicit operator, check whether it is
6577 -- visible because its operand type is properly visible. This check
6578 -- applies to explicit renamed entities that appear in the source in a
6579 -- renaming declaration or a formal subprogram instance, but not to
6580 -- default generic actuals with a name.
6582 function Report_Overload
return Entity_Id
;
6583 -- List possible interpretations, and specialize message in the
6584 -- case of a generic actual.
6586 function Within
(Inner
, Outer
: Entity_Id
) return Boolean;
6587 -- Determine whether a candidate subprogram is defined within the
6588 -- enclosing instance. If yes, it has precedence over outer candidates.
6590 --------------------------
6591 -- Is_Visible_Operation --
6592 --------------------------
6594 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean is
6600 if Ekind
(Op
) /= E_Operator
6601 or else Scope
(Op
) /= Standard_Standard
6602 or else (In_Instance
6603 and then (not Is_Actual
6604 or else Present
(Enclosing_Instance
)))
6609 -- For a fixed point type operator, check the resulting type,
6610 -- because it may be a mixed mode integer * fixed operation.
6612 if Present
(Next_Formal
(First_Formal
(New_S
)))
6613 and then Is_Fixed_Point_Type
(Etype
(New_S
))
6615 Typ
:= Etype
(New_S
);
6617 Typ
:= Etype
(First_Formal
(New_S
));
6620 Btyp
:= Base_Type
(Typ
);
6622 if Nkind
(Nam
) /= N_Expanded_Name
then
6623 return (In_Open_Scopes
(Scope
(Btyp
))
6624 or else Is_Potentially_Use_Visible
(Btyp
)
6625 or else In_Use
(Btyp
)
6626 or else In_Use
(Scope
(Btyp
)));
6629 Scop
:= Entity
(Prefix
(Nam
));
6631 if Ekind
(Scop
) = E_Package
6632 and then Present
(Renamed_Object
(Scop
))
6634 Scop
:= Renamed_Object
(Scop
);
6637 -- Operator is visible if prefix of expanded name denotes
6638 -- scope of type, or else type is defined in System_Aux
6639 -- and the prefix denotes System.
6641 return Scope
(Btyp
) = Scop
6642 or else (Scope
(Btyp
) = System_Aux_Id
6643 and then Scope
(Scope
(Btyp
)) = Scop
);
6646 end Is_Visible_Operation
;
6652 function Within
(Inner
, Outer
: Entity_Id
) return Boolean is
6656 Sc
:= Scope
(Inner
);
6657 while Sc
/= Standard_Standard
loop
6668 ---------------------
6669 -- Report_Overload --
6670 ---------------------
6672 function Report_Overload
return Entity_Id
is
6675 Error_Msg_NE
-- CODEFIX
6676 ("ambiguous actual subprogram&, " &
6677 "possible interpretations:", N
, Nam
);
6679 Error_Msg_N
-- CODEFIX
6680 ("ambiguous subprogram, " &
6681 "possible interpretations:", N
);
6684 List_Interps
(Nam
, N
);
6686 end Report_Overload
;
6688 -- Start of processing for Find_Renamed_Entity
6692 Candidate_Renaming
:= Empty
;
6694 if Is_Overloaded
(Nam
) then
6695 Get_First_Interp
(Nam
, Ind
, It
);
6696 while Present
(It
.Nam
) loop
6697 if Entity_Matches_Spec
(It
.Nam
, New_S
)
6698 and then Is_Visible_Operation
(It
.Nam
)
6700 if Old_S
/= Any_Id
then
6702 -- Note: The call to Disambiguate only happens if a
6703 -- previous interpretation was found, in which case I1
6704 -- has received a value.
6706 It1
:= Disambiguate
(Nam
, I1
, Ind
, Etype
(Old_S
));
6708 if It1
= No_Interp
then
6709 Inst
:= Enclosing_Instance
;
6711 if Present
(Inst
) then
6712 if Within
(It
.Nam
, Inst
) then
6713 if Within
(Old_S
, Inst
) then
6715 -- Choose the innermost subprogram, which would
6716 -- have hidden the outer one in the generic.
6718 if Scope_Depth
(It
.Nam
) <
6727 elsif Within
(Old_S
, Inst
) then
6731 return Report_Overload
;
6734 -- If not within an instance, ambiguity is real
6737 return Report_Overload
;
6751 Present
(First_Formal
(It
.Nam
))
6752 and then Present
(First_Formal
(New_S
))
6753 and then (Base_Type
(Etype
(First_Formal
(It
.Nam
))) =
6754 Base_Type
(Etype
(First_Formal
(New_S
))))
6756 Candidate_Renaming
:= It
.Nam
;
6759 Get_Next_Interp
(Ind
, It
);
6762 Set_Entity
(Nam
, Old_S
);
6764 if Old_S
/= Any_Id
then
6765 Set_Is_Overloaded
(Nam
, False);
6768 -- Non-overloaded case
6772 and then Present
(Enclosing_Instance
)
6773 and then Entity_Matches_Spec
(Entity
(Nam
), New_S
)
6775 Old_S
:= Entity
(Nam
);
6777 elsif Entity_Matches_Spec
(Entity
(Nam
), New_S
) then
6778 Candidate_Renaming
:= New_S
;
6780 if Is_Visible_Operation
(Entity
(Nam
)) then
6781 Old_S
:= Entity
(Nam
);
6784 elsif Present
(First_Formal
(Entity
(Nam
)))
6785 and then Present
(First_Formal
(New_S
))
6786 and then (Base_Type
(Etype
(First_Formal
(Entity
(Nam
)))) =
6787 Base_Type
(Etype
(First_Formal
(New_S
))))
6789 Candidate_Renaming
:= Entity
(Nam
);
6794 end Find_Renamed_Entity
;
6796 -----------------------------
6797 -- Find_Selected_Component --
6798 -----------------------------
6800 procedure Find_Selected_Component
(N
: Node_Id
) is
6801 P
: constant Node_Id
:= Prefix
(N
);
6804 -- Entity denoted by prefix
6811 function Available_Subtype
return Boolean;
6812 -- A small optimization: if the prefix is constrained and the component
6813 -- is an array type we may already have a usable subtype for it, so we
6814 -- can use it rather than generating a new one, because the bounds
6815 -- will be the values of the discriminants and not discriminant refs.
6816 -- This simplifies value tracing in GNATProve. For consistency, both
6817 -- the entity name and the subtype come from the constrained component.
6819 -- This is only used in GNATProve mode: when generating code it may be
6820 -- necessary to create an itype in the scope of use of the selected
6821 -- component, e.g. in the context of a expanded record equality.
6823 function Is_Reference_In_Subunit
return Boolean;
6824 -- In a subunit, the scope depth is not a proper measure of hiding,
6825 -- because the context of the proper body may itself hide entities in
6826 -- parent units. This rare case requires inspecting the tree directly
6827 -- because the proper body is inserted in the main unit and its context
6828 -- is simply added to that of the parent.
6830 -----------------------
6831 -- Available_Subtype --
6832 -----------------------
6834 function Available_Subtype
return Boolean is
6838 if GNATprove_Mode
then
6839 Comp
:= First_Entity
(Etype
(P
));
6840 while Present
(Comp
) loop
6841 if Chars
(Comp
) = Chars
(Selector_Name
(N
)) then
6842 Set_Etype
(N
, Etype
(Comp
));
6843 Set_Entity
(Selector_Name
(N
), Comp
);
6844 Set_Etype
(Selector_Name
(N
), Etype
(Comp
));
6848 Next_Component
(Comp
);
6853 end Available_Subtype
;
6855 -----------------------------
6856 -- Is_Reference_In_Subunit --
6857 -----------------------------
6859 function Is_Reference_In_Subunit
return Boolean is
6861 Comp_Unit
: Node_Id
;
6865 while Present
(Comp_Unit
)
6866 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
6868 Comp_Unit
:= Parent
(Comp_Unit
);
6871 if No
(Comp_Unit
) or else Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
6875 -- Now check whether the package is in the context of the subunit
6877 Clause
:= First
(Context_Items
(Comp_Unit
));
6878 while Present
(Clause
) loop
6879 if Nkind
(Clause
) = N_With_Clause
6880 and then Entity
(Name
(Clause
)) = P_Name
6885 Clause
:= Next
(Clause
);
6889 end Is_Reference_In_Subunit
;
6891 -- Start of processing for Find_Selected_Component
6896 if Nkind
(P
) = N_Error
then
6900 -- Selector name cannot be a character literal or an operator symbol in
6901 -- SPARK, except for the operator symbol in a renaming.
6903 if Restriction_Check_Required
(SPARK_05
) then
6904 if Nkind
(Selector_Name
(N
)) = N_Character_Literal
then
6905 Check_SPARK_05_Restriction
6906 ("character literal cannot be prefixed", N
);
6907 elsif Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
6908 and then Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
6910 Check_SPARK_05_Restriction
6911 ("operator symbol cannot be prefixed", N
);
6915 -- If the selector already has an entity, the node has been constructed
6916 -- in the course of expansion, and is known to be valid. Do not verify
6917 -- that it is defined for the type (it may be a private component used
6918 -- in the expansion of record equality).
6920 if Present
(Entity
(Selector_Name
(N
))) then
6921 if No
(Etype
(N
)) or else Etype
(N
) = Any_Type
then
6923 Sel_Name
: constant Node_Id
:= Selector_Name
(N
);
6924 Selector
: constant Entity_Id
:= Entity
(Sel_Name
);
6928 Set_Etype
(Sel_Name
, Etype
(Selector
));
6930 if not Is_Entity_Name
(P
) then
6934 -- Build an actual subtype except for the first parameter
6935 -- of an init proc, where this actual subtype is by
6936 -- definition incorrect, since the object is uninitialized
6937 -- (and does not even have defined discriminants etc.)
6939 if Is_Entity_Name
(P
)
6940 and then Ekind
(Entity
(P
)) = E_Function
6942 Nam
:= New_Copy
(P
);
6944 if Is_Overloaded
(P
) then
6945 Save_Interps
(P
, Nam
);
6948 Rewrite
(P
, Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
6950 Analyze_Selected_Component
(N
);
6953 elsif Ekind
(Selector
) = E_Component
6954 and then (not Is_Entity_Name
(P
)
6955 or else Chars
(Entity
(P
)) /= Name_uInit
)
6957 -- Check if we already have an available subtype we can use
6959 if Ekind
(Etype
(P
)) = E_Record_Subtype
6960 and then Nkind
(Parent
(Etype
(P
))) = N_Subtype_Declaration
6961 and then Is_Array_Type
(Etype
(Selector
))
6962 and then not Is_Packed
(Etype
(Selector
))
6963 and then Available_Subtype
6967 -- Do not build the subtype when referencing components of
6968 -- dispatch table wrappers. Required to avoid generating
6969 -- elaboration code with HI runtimes.
6971 elsif RTU_Loaded
(Ada_Tags
)
6973 ((RTE_Available
(RE_Dispatch_Table_Wrapper
)
6974 and then Scope
(Selector
) =
6975 RTE
(RE_Dispatch_Table_Wrapper
))
6977 (RTE_Available
(RE_No_Dispatch_Table_Wrapper
)
6978 and then Scope
(Selector
) =
6979 RTE
(RE_No_Dispatch_Table_Wrapper
)))
6984 Build_Actual_Subtype_Of_Component
6985 (Etype
(Selector
), N
);
6992 if No
(C_Etype
) then
6993 C_Etype
:= Etype
(Selector
);
6995 Insert_Action
(N
, C_Etype
);
6996 C_Etype
:= Defining_Identifier
(C_Etype
);
6999 Set_Etype
(N
, C_Etype
);
7002 -- If this is the name of an entry or protected operation, and
7003 -- the prefix is an access type, insert an explicit dereference,
7004 -- so that entry calls are treated uniformly.
7006 if Is_Access_Type
(Etype
(P
))
7007 and then Is_Concurrent_Type
(Designated_Type
(Etype
(P
)))
7010 New_P
: constant Node_Id
:=
7011 Make_Explicit_Dereference
(Sloc
(P
),
7012 Prefix
=> Relocate_Node
(P
));
7015 Set_Etype
(P
, Designated_Type
(Etype
(Prefix
(P
))));
7019 -- If the selected component appears within a default expression
7020 -- and it has an actual subtype, the pre-analysis has not yet
7021 -- completed its analysis, because Insert_Actions is disabled in
7022 -- that context. Within the init proc of the enclosing type we
7023 -- must complete this analysis, if an actual subtype was created.
7025 elsif Inside_Init_Proc
then
7027 Typ
: constant Entity_Id
:= Etype
(N
);
7028 Decl
: constant Node_Id
:= Declaration_Node
(Typ
);
7030 if Nkind
(Decl
) = N_Subtype_Declaration
7031 and then not Analyzed
(Decl
)
7032 and then Is_List_Member
(Decl
)
7033 and then No
(Parent
(Decl
))
7036 Insert_Action
(N
, Decl
);
7043 elsif Is_Entity_Name
(P
) then
7044 P_Name
:= Entity
(P
);
7046 -- The prefix may denote an enclosing type which is the completion
7047 -- of an incomplete type declaration.
7049 if Is_Type
(P_Name
) then
7050 Set_Entity
(P
, Get_Full_View
(P_Name
));
7051 Set_Etype
(P
, Entity
(P
));
7052 P_Name
:= Entity
(P
);
7055 P_Type
:= Base_Type
(Etype
(P
));
7057 if Debug_Flag_E
then
7058 Write_Str
("Found prefix type to be ");
7059 Write_Entity_Info
(P_Type
, " "); Write_Eol
;
7062 -- The designated type may be a limited view with no components.
7063 -- Check whether the non-limited view is available, because in some
7064 -- cases this will not be set when installing the context. Rewrite
7065 -- the node by introducing an explicit dereference at once, and
7066 -- setting the type of the rewritten prefix to the non-limited view
7067 -- of the original designated type.
7069 if Is_Access_Type
(P_Type
) then
7071 Desig_Typ
: constant Entity_Id
:=
7072 Directly_Designated_Type
(P_Type
);
7075 if Is_Incomplete_Type
(Desig_Typ
)
7076 and then From_Limited_With
(Desig_Typ
)
7077 and then Present
(Non_Limited_View
(Desig_Typ
))
7080 Make_Explicit_Dereference
(Sloc
(P
),
7081 Prefix
=> Relocate_Node
(P
)));
7083 Set_Etype
(P
, Get_Full_View
(Non_Limited_View
(Desig_Typ
)));
7084 P_Type
:= Etype
(P
);
7089 -- First check for components of a record object (not the
7090 -- result of a call, which is handled below).
7092 if Is_Appropriate_For_Record
(P_Type
)
7093 and then not Is_Overloadable
(P_Name
)
7094 and then not Is_Type
(P_Name
)
7096 -- Selected component of record. Type checking will validate
7097 -- name of selector.
7099 -- ??? Could we rewrite an implicit dereference into an explicit
7102 Analyze_Selected_Component
(N
);
7104 -- Reference to type name in predicate/invariant expression
7106 elsif Is_Appropriate_For_Entry_Prefix
(P_Type
)
7107 and then not In_Open_Scopes
(P_Name
)
7108 and then (not Is_Concurrent_Type
(Etype
(P_Name
))
7109 or else not In_Open_Scopes
(Etype
(P_Name
)))
7111 -- Call to protected operation or entry. Type checking is
7112 -- needed on the prefix.
7114 Analyze_Selected_Component
(N
);
7116 elsif (In_Open_Scopes
(P_Name
)
7117 and then Ekind
(P_Name
) /= E_Void
7118 and then not Is_Overloadable
(P_Name
))
7119 or else (Is_Concurrent_Type
(Etype
(P_Name
))
7120 and then In_Open_Scopes
(Etype
(P_Name
)))
7122 -- Prefix denotes an enclosing loop, block, or task, i.e. an
7123 -- enclosing construct that is not a subprogram or accept.
7125 -- A special case: a protected body may call an operation
7126 -- on an external object of the same type, in which case it
7127 -- is not an expanded name. If the prefix is the type itself,
7128 -- or the context is a single synchronized object it can only
7129 -- be interpreted as an expanded name.
7131 if Is_Concurrent_Type
(Etype
(P_Name
)) then
7133 or else Present
(Anonymous_Object
(Etype
(P_Name
)))
7135 Find_Expanded_Name
(N
);
7138 Analyze_Selected_Component
(N
);
7143 Find_Expanded_Name
(N
);
7146 elsif Ekind
(P_Name
) = E_Package
then
7147 Find_Expanded_Name
(N
);
7149 elsif Is_Overloadable
(P_Name
) then
7151 -- The subprogram may be a renaming (of an enclosing scope) as
7152 -- in the case of the name of the generic within an instantiation.
7154 if Ekind_In
(P_Name
, E_Procedure
, E_Function
)
7155 and then Present
(Alias
(P_Name
))
7156 and then Is_Generic_Instance
(Alias
(P_Name
))
7158 P_Name
:= Alias
(P_Name
);
7161 if Is_Overloaded
(P
) then
7163 -- The prefix must resolve to a unique enclosing construct
7166 Found
: Boolean := False;
7171 Get_First_Interp
(P
, Ind
, It
);
7172 while Present
(It
.Nam
) loop
7173 if In_Open_Scopes
(It
.Nam
) then
7176 "prefix must be unique enclosing scope", N
);
7177 Set_Entity
(N
, Any_Id
);
7178 Set_Etype
(N
, Any_Type
);
7187 Get_Next_Interp
(Ind
, It
);
7192 if In_Open_Scopes
(P_Name
) then
7193 Set_Entity
(P
, P_Name
);
7194 Set_Is_Overloaded
(P
, False);
7195 Find_Expanded_Name
(N
);
7198 -- If no interpretation as an expanded name is possible, it
7199 -- must be a selected component of a record returned by a
7200 -- function call. Reformat prefix as a function call, the rest
7201 -- is done by type resolution.
7203 -- Error if the prefix is procedure or entry, as is P.X
7205 if Ekind
(P_Name
) /= E_Function
7207 (not Is_Overloaded
(P
)
7208 or else Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
)
7210 -- Prefix may mention a package that is hidden by a local
7211 -- declaration: let the user know. Scan the full homonym
7212 -- chain, the candidate package may be anywhere on it.
7214 if Present
(Homonym
(Current_Entity
(P_Name
))) then
7215 P_Name
:= Current_Entity
(P_Name
);
7217 while Present
(P_Name
) loop
7218 exit when Ekind
(P_Name
) = E_Package
;
7219 P_Name
:= Homonym
(P_Name
);
7222 if Present
(P_Name
) then
7223 if not Is_Reference_In_Subunit
then
7224 Error_Msg_Sloc
:= Sloc
(Entity
(Prefix
(N
)));
7226 ("package& is hidden by declaration#", N
, P_Name
);
7229 Set_Entity
(Prefix
(N
), P_Name
);
7230 Find_Expanded_Name
(N
);
7234 P_Name
:= Entity
(Prefix
(N
));
7239 ("invalid prefix in selected component&", N
, P_Name
);
7240 Change_Selected_Component_To_Expanded_Name
(N
);
7241 Set_Entity
(N
, Any_Id
);
7242 Set_Etype
(N
, Any_Type
);
7244 -- Here we have a function call, so do the reformatting
7247 Nam
:= New_Copy
(P
);
7248 Save_Interps
(P
, Nam
);
7250 -- We use Replace here because this is one of those cases
7251 -- where the parser has missclassified the node, and we fix
7252 -- things up and then do the semantic analysis on the fixed
7253 -- up node. Normally we do this using one of the Sinfo.CN
7254 -- routines, but this is too tricky for that.
7256 -- Note that using Rewrite would be wrong, because we would
7257 -- have a tree where the original node is unanalyzed, and
7258 -- this violates the required interface for ASIS.
7261 Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
7263 -- Now analyze the reformatted node
7267 -- If the prefix is illegal after this transformation, there
7268 -- may be visibility errors on the prefix. The safest is to
7269 -- treat the selected component as an error.
7271 if Error_Posted
(P
) then
7272 Set_Etype
(N
, Any_Type
);
7276 Analyze_Selected_Component
(N
);
7281 -- Remaining cases generate various error messages
7284 -- Format node as expanded name, to avoid cascaded errors
7286 -- If the limited_with transformation was applied earlier, restore
7287 -- source for proper error reporting.
7289 if not Comes_From_Source
(P
)
7290 and then Nkind
(P
) = N_Explicit_Dereference
7292 Rewrite
(P
, Prefix
(P
));
7293 P_Type
:= Etype
(P
);
7296 Change_Selected_Component_To_Expanded_Name
(N
);
7297 Set_Entity
(N
, Any_Id
);
7298 Set_Etype
(N
, Any_Type
);
7300 -- Issue error message, but avoid this if error issued already.
7301 -- Use identifier of prefix if one is available.
7303 if P_Name
= Any_Id
then
7306 -- It is not an error if the prefix is the current instance of
7307 -- type name, e.g. the expression of a type aspect, when it is
7308 -- analyzed for ASIS use.
7310 elsif Is_Entity_Name
(P
) and then Is_Current_Instance
(P
) then
7313 elsif Ekind
(P_Name
) = E_Void
then
7314 Premature_Usage
(P
);
7316 elsif Nkind
(P
) /= N_Attribute_Reference
then
7318 -- This may have been meant as a prefixed call to a primitive
7319 -- of an untagged type. If it is a function call check type of
7320 -- its first formal and add explanation.
7323 F
: constant Entity_Id
:=
7324 Current_Entity
(Selector_Name
(N
));
7327 and then Is_Overloadable
(F
)
7328 and then Present
(First_Entity
(F
))
7329 and then not Is_Tagged_Type
(Etype
(First_Entity
(F
)))
7332 ("prefixed call is only allowed for objects of a "
7333 & "tagged type", N
);
7337 Error_Msg_N
("invalid prefix in selected component&", P
);
7339 if Is_Access_Type
(P_Type
)
7340 and then Ekind
(Designated_Type
(P_Type
)) = E_Incomplete_Type
7343 ("\dereference must not be of an incomplete type "
7344 & "(RM 3.10.1)", P
);
7348 Error_Msg_N
("invalid prefix in selected component", P
);
7352 -- Selector name is restricted in SPARK
7354 if Nkind
(N
) = N_Expanded_Name
7355 and then Restriction_Check_Required
(SPARK_05
)
7357 if Is_Subprogram
(P_Name
) then
7358 Check_SPARK_05_Restriction
7359 ("prefix of expanded name cannot be a subprogram", P
);
7360 elsif Ekind
(P_Name
) = E_Loop
then
7361 Check_SPARK_05_Restriction
7362 ("prefix of expanded name cannot be a loop statement", P
);
7367 -- If prefix is not the name of an entity, it must be an expression,
7368 -- whose type is appropriate for a record. This is determined by
7371 Analyze_Selected_Component
(N
);
7374 Analyze_Dimension
(N
);
7375 end Find_Selected_Component
;
7381 procedure Find_Type
(N
: Node_Id
) is
7391 elsif Nkind
(N
) = N_Attribute_Reference
then
7393 -- Class attribute. This is not valid in Ada 83 mode, but we do not
7394 -- need to enforce that at this point, since the declaration of the
7395 -- tagged type in the prefix would have been flagged already.
7397 if Attribute_Name
(N
) = Name_Class
then
7398 Check_Restriction
(No_Dispatch
, N
);
7399 Find_Type
(Prefix
(N
));
7401 -- Propagate error from bad prefix
7403 if Etype
(Prefix
(N
)) = Any_Type
then
7404 Set_Entity
(N
, Any_Type
);
7405 Set_Etype
(N
, Any_Type
);
7409 T
:= Base_Type
(Entity
(Prefix
(N
)));
7411 -- Case where type is not known to be tagged. Its appearance in
7412 -- the prefix of the 'Class attribute indicates that the full view
7415 if not Is_Tagged_Type
(T
) then
7416 if Ekind
(T
) = E_Incomplete_Type
then
7418 -- It is legal to denote the class type of an incomplete
7419 -- type. The full type will have to be tagged, of course.
7420 -- In Ada 2005 this usage is declared obsolescent, so we
7421 -- warn accordingly. This usage is only legal if the type
7422 -- is completed in the current scope, and not for a limited
7425 if Ada_Version
>= Ada_2005
then
7427 -- Test whether the Available_View of a limited type view
7428 -- is tagged, since the limited view may not be marked as
7429 -- tagged if the type itself has an untagged incomplete
7430 -- type view in its package.
7432 if From_Limited_With
(T
)
7433 and then not Is_Tagged_Type
(Available_View
(T
))
7436 ("prefix of Class attribute must be tagged", N
);
7437 Set_Etype
(N
, Any_Type
);
7438 Set_Entity
(N
, Any_Type
);
7441 -- ??? This test is temporarily disabled (always
7442 -- False) because it causes an unwanted warning on
7443 -- GNAT sources (built with -gnatg, which includes
7444 -- Warn_On_Obsolescent_ Feature). Once this issue
7445 -- is cleared in the sources, it can be enabled.
7447 elsif Warn_On_Obsolescent_Feature
and then False then
7449 ("applying 'Class to an untagged incomplete type"
7450 & " is an obsolescent feature (RM J.11)?r?", N
);
7454 Set_Is_Tagged_Type
(T
);
7455 Set_Direct_Primitive_Operations
(T
, New_Elmt_List
);
7456 Make_Class_Wide_Type
(T
);
7457 Set_Entity
(N
, Class_Wide_Type
(T
));
7458 Set_Etype
(N
, Class_Wide_Type
(T
));
7460 elsif Ekind
(T
) = E_Private_Type
7461 and then not Is_Generic_Type
(T
)
7462 and then In_Private_Part
(Scope
(T
))
7464 -- The Class attribute can be applied to an untagged private
7465 -- type fulfilled by a tagged type prior to the full type
7466 -- declaration (but only within the parent package's private
7467 -- part). Create the class-wide type now and check that the
7468 -- full type is tagged later during its analysis. Note that
7469 -- we do not mark the private type as tagged, unlike the
7470 -- case of incomplete types, because the type must still
7471 -- appear untagged to outside units.
7473 if No
(Class_Wide_Type
(T
)) then
7474 Make_Class_Wide_Type
(T
);
7477 Set_Entity
(N
, Class_Wide_Type
(T
));
7478 Set_Etype
(N
, Class_Wide_Type
(T
));
7481 -- Should we introduce a type Any_Tagged and use Wrong_Type
7482 -- here, it would be a bit more consistent???
7485 ("tagged type required, found}",
7486 Prefix
(N
), First_Subtype
(T
));
7487 Set_Entity
(N
, Any_Type
);
7491 -- Case of tagged type
7494 if Is_Concurrent_Type
(T
) then
7495 if No
(Corresponding_Record_Type
(Entity
(Prefix
(N
)))) then
7497 -- Previous error. Create a class-wide type for the
7498 -- synchronized type itself, with minimal semantic
7499 -- attributes, to catch other errors in some ACATS tests.
7501 pragma Assert
(Serious_Errors_Detected
/= 0);
7502 Make_Class_Wide_Type
(T
);
7503 C
:= Class_Wide_Type
(T
);
7504 Set_First_Entity
(C
, First_Entity
(T
));
7507 C
:= Class_Wide_Type
7508 (Corresponding_Record_Type
(Entity
(Prefix
(N
))));
7512 C
:= Class_Wide_Type
(Entity
(Prefix
(N
)));
7515 Set_Entity_With_Checks
(N
, C
);
7516 Generate_Reference
(C
, N
);
7520 -- Base attribute, not allowed in Ada 83
7522 elsif Attribute_Name
(N
) = Name_Base
then
7523 Error_Msg_Name_1
:= Name_Base
;
7524 Check_SPARK_05_Restriction
7525 ("attribute% is only allowed as prefix of another attribute", N
);
7527 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
7529 ("(Ada 83) Base attribute not allowed in subtype mark", N
);
7532 Find_Type
(Prefix
(N
));
7533 Typ
:= Entity
(Prefix
(N
));
7535 if Ada_Version
>= Ada_95
7536 and then not Is_Scalar_Type
(Typ
)
7537 and then not Is_Generic_Type
(Typ
)
7540 ("prefix of Base attribute must be scalar type",
7543 elsif Warn_On_Redundant_Constructs
7544 and then Base_Type
(Typ
) = Typ
7546 Error_Msg_NE
-- CODEFIX
7547 ("redundant attribute, & is its own base type?r?", N
, Typ
);
7550 T
:= Base_Type
(Typ
);
7552 -- Rewrite attribute reference with type itself (see similar
7553 -- processing in Analyze_Attribute, case Base). Preserve prefix
7554 -- if present, for other legality checks.
7556 if Nkind
(Prefix
(N
)) = N_Expanded_Name
then
7558 Make_Expanded_Name
(Sloc
(N
),
7560 Prefix
=> New_Copy
(Prefix
(Prefix
(N
))),
7561 Selector_Name
=> New_Occurrence_Of
(T
, Sloc
(N
))));
7564 Rewrite
(N
, New_Occurrence_Of
(T
, Sloc
(N
)));
7571 elsif Attribute_Name
(N
) = Name_Stub_Type
then
7573 -- This is handled in Analyze_Attribute
7577 -- All other attributes are invalid in a subtype mark
7580 Error_Msg_N
("invalid attribute in subtype mark", N
);
7586 if Is_Entity_Name
(N
) then
7587 T_Name
:= Entity
(N
);
7589 Error_Msg_N
("subtype mark required in this context", N
);
7590 Set_Etype
(N
, Any_Type
);
7594 if T_Name
= Any_Id
or else Etype
(N
) = Any_Type
then
7596 -- Undefined id. Make it into a valid type
7598 Set_Entity
(N
, Any_Type
);
7600 elsif not Is_Type
(T_Name
)
7601 and then T_Name
/= Standard_Void_Type
7603 Error_Msg_Sloc
:= Sloc
(T_Name
);
7604 Error_Msg_N
("subtype mark required in this context", N
);
7605 Error_Msg_NE
("\\found & declared#", N
, T_Name
);
7606 Set_Entity
(N
, Any_Type
);
7609 -- If the type is an incomplete type created to handle
7610 -- anonymous access components of a record type, then the
7611 -- incomplete type is the visible entity and subsequent
7612 -- references will point to it. Mark the original full
7613 -- type as referenced, to prevent spurious warnings.
7615 if Is_Incomplete_Type
(T_Name
)
7616 and then Present
(Full_View
(T_Name
))
7617 and then not Comes_From_Source
(T_Name
)
7619 Set_Referenced
(Full_View
(T_Name
));
7622 T_Name
:= Get_Full_View
(T_Name
);
7624 -- Ada 2005 (AI-251, AI-50217): Handle interfaces visible through
7625 -- limited-with clauses
7627 if From_Limited_With
(T_Name
)
7628 and then Ekind
(T_Name
) in Incomplete_Kind
7629 and then Present
(Non_Limited_View
(T_Name
))
7630 and then Is_Interface
(Non_Limited_View
(T_Name
))
7632 T_Name
:= Non_Limited_View
(T_Name
);
7635 if In_Open_Scopes
(T_Name
) then
7636 if Ekind
(Base_Type
(T_Name
)) = E_Task_Type
then
7638 -- In Ada 2005, a task name can be used in an access
7639 -- definition within its own body. It cannot be used
7640 -- in the discriminant part of the task declaration,
7641 -- nor anywhere else in the declaration because entries
7642 -- cannot have access parameters.
7644 if Ada_Version
>= Ada_2005
7645 and then Nkind
(Parent
(N
)) = N_Access_Definition
7647 Set_Entity
(N
, T_Name
);
7648 Set_Etype
(N
, T_Name
);
7650 if Has_Completion
(T_Name
) then
7655 ("task type cannot be used as type mark " &
7656 "within its own declaration", N
);
7661 ("task type cannot be used as type mark " &
7662 "within its own spec or body", N
);
7665 elsif Ekind
(Base_Type
(T_Name
)) = E_Protected_Type
then
7667 -- In Ada 2005, a protected name can be used in an access
7668 -- definition within its own body.
7670 if Ada_Version
>= Ada_2005
7671 and then Nkind
(Parent
(N
)) = N_Access_Definition
7673 Set_Entity
(N
, T_Name
);
7674 Set_Etype
(N
, T_Name
);
7679 ("protected type cannot be used as type mark " &
7680 "within its own spec or body", N
);
7684 Error_Msg_N
("type declaration cannot refer to itself", N
);
7687 Set_Etype
(N
, Any_Type
);
7688 Set_Entity
(N
, Any_Type
);
7689 Set_Error_Posted
(T_Name
);
7693 Set_Entity
(N
, T_Name
);
7694 Set_Etype
(N
, T_Name
);
7698 if Present
(Etype
(N
)) and then Comes_From_Source
(N
) then
7699 if Is_Fixed_Point_Type
(Etype
(N
)) then
7700 Check_Restriction
(No_Fixed_Point
, N
);
7701 elsif Is_Floating_Point_Type
(Etype
(N
)) then
7702 Check_Restriction
(No_Floating_Point
, N
);
7705 -- A Ghost type must appear in a specific context
7707 if Is_Ghost_Entity
(Etype
(N
)) then
7708 Check_Ghost_Context
(Etype
(N
), N
);
7713 ------------------------------------
7714 -- Has_Implicit_Character_Literal --
7715 ------------------------------------
7717 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean is
7719 Found
: Boolean := False;
7720 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
7721 Priv_Id
: Entity_Id
:= Empty
;
7724 if Ekind
(P
) = E_Package
and then not In_Open_Scopes
(P
) then
7725 Priv_Id
:= First_Private_Entity
(P
);
7728 if P
= Standard_Standard
then
7729 Change_Selected_Component_To_Expanded_Name
(N
);
7730 Rewrite
(N
, Selector_Name
(N
));
7732 Set_Etype
(Original_Node
(N
), Standard_Character
);
7736 Id
:= First_Entity
(P
);
7737 while Present
(Id
) and then Id
/= Priv_Id
loop
7738 if Is_Standard_Character_Type
(Id
) and then Is_Base_Type
(Id
) then
7740 -- We replace the node with the literal itself, resolve as a
7741 -- character, and set the type correctly.
7744 Change_Selected_Component_To_Expanded_Name
(N
);
7745 Rewrite
(N
, Selector_Name
(N
));
7748 Set_Etype
(Original_Node
(N
), Id
);
7752 -- More than one type derived from Character in given scope.
7753 -- Collect all possible interpretations.
7755 Add_One_Interp
(N
, Id
, Id
);
7763 end Has_Implicit_Character_Literal
;
7765 ----------------------
7766 -- Has_Private_With --
7767 ----------------------
7769 function Has_Private_With
(E
: Entity_Id
) return Boolean is
7770 Comp_Unit
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
7774 Item
:= First
(Context_Items
(Comp_Unit
));
7775 while Present
(Item
) loop
7776 if Nkind
(Item
) = N_With_Clause
7777 and then Private_Present
(Item
)
7778 and then Entity
(Name
(Item
)) = E
7787 end Has_Private_With
;
7789 ---------------------------
7790 -- Has_Implicit_Operator --
7791 ---------------------------
7793 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean is
7794 Op_Id
: constant Name_Id
:= Chars
(Selector_Name
(N
));
7795 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
7797 Priv_Id
: Entity_Id
:= Empty
;
7799 procedure Add_Implicit_Operator
7801 Op_Type
: Entity_Id
:= Empty
);
7802 -- Add implicit interpretation to node N, using the type for which a
7803 -- predefined operator exists. If the operator yields a boolean type,
7804 -- the Operand_Type is implicitly referenced by the operator, and a
7805 -- reference to it must be generated.
7807 ---------------------------
7808 -- Add_Implicit_Operator --
7809 ---------------------------
7811 procedure Add_Implicit_Operator
7813 Op_Type
: Entity_Id
:= Empty
)
7815 Predef_Op
: Entity_Id
;
7818 Predef_Op
:= Current_Entity
(Selector_Name
(N
));
7819 while Present
(Predef_Op
)
7820 and then Scope
(Predef_Op
) /= Standard_Standard
7822 Predef_Op
:= Homonym
(Predef_Op
);
7825 if Nkind
(N
) = N_Selected_Component
then
7826 Change_Selected_Component_To_Expanded_Name
(N
);
7829 -- If the context is an unanalyzed function call, determine whether
7830 -- a binary or unary interpretation is required.
7832 if Nkind
(Parent
(N
)) = N_Indexed_Component
then
7834 Is_Binary_Call
: constant Boolean :=
7836 (Next
(First
(Expressions
(Parent
(N
)))));
7837 Is_Binary_Op
: constant Boolean :=
7839 (Predef_Op
) /= Last_Entity
(Predef_Op
);
7840 Predef_Op2
: constant Entity_Id
:= Homonym
(Predef_Op
);
7843 if Is_Binary_Call
then
7844 if Is_Binary_Op
then
7845 Add_One_Interp
(N
, Predef_Op
, T
);
7847 Add_One_Interp
(N
, Predef_Op2
, T
);
7851 if not Is_Binary_Op
then
7852 Add_One_Interp
(N
, Predef_Op
, T
);
7854 Add_One_Interp
(N
, Predef_Op2
, T
);
7860 Add_One_Interp
(N
, Predef_Op
, T
);
7862 -- For operators with unary and binary interpretations, if
7863 -- context is not a call, add both
7865 if Present
(Homonym
(Predef_Op
)) then
7866 Add_One_Interp
(N
, Homonym
(Predef_Op
), T
);
7870 -- The node is a reference to a predefined operator, and
7871 -- an implicit reference to the type of its operands.
7873 if Present
(Op_Type
) then
7874 Generate_Operator_Reference
(N
, Op_Type
);
7876 Generate_Operator_Reference
(N
, T
);
7878 end Add_Implicit_Operator
;
7880 -- Start of processing for Has_Implicit_Operator
7883 if Ekind
(P
) = E_Package
and then not In_Open_Scopes
(P
) then
7884 Priv_Id
:= First_Private_Entity
(P
);
7887 Id
:= First_Entity
(P
);
7891 -- Boolean operators: an implicit declaration exists if the scope
7892 -- contains a declaration for a derived Boolean type, or for an
7893 -- array of Boolean type.
7900 while Id
/= Priv_Id
loop
7901 if Valid_Boolean_Arg
(Id
) and then Is_Base_Type
(Id
) then
7902 Add_Implicit_Operator
(Id
);
7909 -- Equality: look for any non-limited type (result is Boolean)
7914 while Id
/= Priv_Id
loop
7916 and then not Is_Limited_Type
(Id
)
7917 and then Is_Base_Type
(Id
)
7919 Add_Implicit_Operator
(Standard_Boolean
, Id
);
7926 -- Comparison operators: scalar type, or array of scalar
7933 while Id
/= Priv_Id
loop
7934 if (Is_Scalar_Type
(Id
)
7935 or else (Is_Array_Type
(Id
)
7936 and then Is_Scalar_Type
(Component_Type
(Id
))))
7937 and then Is_Base_Type
(Id
)
7939 Add_Implicit_Operator
(Standard_Boolean
, Id
);
7946 -- Arithmetic operators: any numeric type
7957 while Id
/= Priv_Id
loop
7958 if Is_Numeric_Type
(Id
) and then Is_Base_Type
(Id
) then
7959 Add_Implicit_Operator
(Id
);
7966 -- Concatenation: any one-dimensional array type
7968 when Name_Op_Concat
=>
7969 while Id
/= Priv_Id
loop
7970 if Is_Array_Type
(Id
)
7971 and then Number_Dimensions
(Id
) = 1
7972 and then Is_Base_Type
(Id
)
7974 Add_Implicit_Operator
(Id
);
7981 -- What is the others condition here? Should we be using a
7982 -- subtype of Name_Id that would restrict to operators ???
7988 -- If we fall through, then we do not have an implicit operator
7991 end Has_Implicit_Operator
;
7993 -----------------------------------
7994 -- Has_Loop_In_Inner_Open_Scopes --
7995 -----------------------------------
7997 function Has_Loop_In_Inner_Open_Scopes
(S
: Entity_Id
) return Boolean is
7999 -- Several scope stacks are maintained by Scope_Stack. The base of the
8000 -- currently active scope stack is denoted by the Is_Active_Stack_Base
8001 -- flag in the scope stack entry. Note that the scope stacks used to
8002 -- simply be delimited implicitly by the presence of Standard_Standard
8003 -- at their base, but there now are cases where this is not sufficient
8004 -- because Standard_Standard actually may appear in the middle of the
8005 -- active set of scopes.
8007 for J
in reverse 0 .. Scope_Stack
.Last
loop
8009 -- S was reached without seing a loop scope first
8011 if Scope_Stack
.Table
(J
).Entity
= S
then
8014 -- S was not yet reached, so it contains at least one inner loop
8016 elsif Ekind
(Scope_Stack
.Table
(J
).Entity
) = E_Loop
then
8020 -- Check Is_Active_Stack_Base to tell us when to stop, as there are
8021 -- cases where Standard_Standard appears in the middle of the active
8022 -- set of scopes. This affects the declaration and overriding of
8023 -- private inherited operations in instantiations of generic child
8026 pragma Assert
(not Scope_Stack
.Table
(J
).Is_Active_Stack_Base
);
8029 raise Program_Error
; -- unreachable
8030 end Has_Loop_In_Inner_Open_Scopes
;
8032 --------------------
8033 -- In_Open_Scopes --
8034 --------------------
8036 function In_Open_Scopes
(S
: Entity_Id
) return Boolean is
8038 -- Several scope stacks are maintained by Scope_Stack. The base of the
8039 -- currently active scope stack is denoted by the Is_Active_Stack_Base
8040 -- flag in the scope stack entry. Note that the scope stacks used to
8041 -- simply be delimited implicitly by the presence of Standard_Standard
8042 -- at their base, but there now are cases where this is not sufficient
8043 -- because Standard_Standard actually may appear in the middle of the
8044 -- active set of scopes.
8046 for J
in reverse 0 .. Scope_Stack
.Last
loop
8047 if Scope_Stack
.Table
(J
).Entity
= S
then
8051 -- Check Is_Active_Stack_Base to tell us when to stop, as there are
8052 -- cases where Standard_Standard appears in the middle of the active
8053 -- set of scopes. This affects the declaration and overriding of
8054 -- private inherited operations in instantiations of generic child
8057 exit when Scope_Stack
.Table
(J
).Is_Active_Stack_Base
;
8063 -----------------------------
8064 -- Inherit_Renamed_Profile --
8065 -----------------------------
8067 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
) is
8074 if Ekind
(Old_S
) = E_Operator
then
8075 New_F
:= First_Formal
(New_S
);
8077 while Present
(New_F
) loop
8078 Set_Etype
(New_F
, Base_Type
(Etype
(New_F
)));
8079 Next_Formal
(New_F
);
8082 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
8085 New_F
:= First_Formal
(New_S
);
8086 Old_F
:= First_Formal
(Old_S
);
8088 while Present
(New_F
) loop
8089 New_T
:= Etype
(New_F
);
8090 Old_T
:= Etype
(Old_F
);
8092 -- If the new type is a renaming of the old one, as is the case
8093 -- for actuals in instances, retain its name, to simplify later
8096 if Nkind
(Parent
(New_T
)) = N_Subtype_Declaration
8097 and then Is_Entity_Name
(Subtype_Indication
(Parent
(New_T
)))
8098 and then Entity
(Subtype_Indication
(Parent
(New_T
))) = Old_T
8102 Set_Etype
(New_F
, Old_T
);
8105 Next_Formal
(New_F
);
8106 Next_Formal
(Old_F
);
8109 pragma Assert
(No
(Old_F
));
8111 if Ekind_In
(Old_S
, E_Function
, E_Enumeration_Literal
) then
8112 Set_Etype
(New_S
, Etype
(Old_S
));
8115 end Inherit_Renamed_Profile
;
8121 procedure Initialize
is
8126 -------------------------
8127 -- Install_Use_Clauses --
8128 -------------------------
8130 procedure Install_Use_Clauses
8132 Force_Installation
: Boolean := False)
8138 while Present
(U
) loop
8140 -- Case of USE package
8142 if Nkind
(U
) = N_Use_Package_Clause
then
8143 Use_One_Package
(U
, Name
(U
), True);
8148 Use_One_Type
(Subtype_Mark
(U
), Force
=> Force_Installation
);
8152 Next_Use_Clause
(U
);
8154 end Install_Use_Clauses
;
8156 -------------------------------------
8157 -- Is_Appropriate_For_Entry_Prefix --
8158 -------------------------------------
8160 function Is_Appropriate_For_Entry_Prefix
(T
: Entity_Id
) return Boolean is
8161 P_Type
: Entity_Id
:= T
;
8164 if Is_Access_Type
(P_Type
) then
8165 P_Type
:= Designated_Type
(P_Type
);
8168 return Is_Task_Type
(P_Type
) or else Is_Protected_Type
(P_Type
);
8169 end Is_Appropriate_For_Entry_Prefix
;
8171 -------------------------------
8172 -- Is_Appropriate_For_Record --
8173 -------------------------------
8175 function Is_Appropriate_For_Record
(T
: Entity_Id
) return Boolean is
8177 function Has_Components
(T1
: Entity_Id
) return Boolean;
8178 -- Determine if given type has components (i.e. is either a record
8179 -- type or a type that has discriminants).
8181 --------------------
8182 -- Has_Components --
8183 --------------------
8185 function Has_Components
(T1
: Entity_Id
) return Boolean is
8187 return Is_Record_Type
(T1
)
8188 or else (Is_Private_Type
(T1
) and then Has_Discriminants
(T1
))
8189 or else (Is_Task_Type
(T1
) and then Has_Discriminants
(T1
))
8190 or else (Is_Incomplete_Type
(T1
)
8191 and then From_Limited_With
(T1
)
8192 and then Present
(Non_Limited_View
(T1
))
8193 and then Is_Record_Type
8194 (Get_Full_View
(Non_Limited_View
(T1
))));
8197 -- Start of processing for Is_Appropriate_For_Record
8202 and then (Has_Components
(T
)
8203 or else (Is_Access_Type
(T
)
8204 and then Has_Components
(Designated_Type
(T
))));
8205 end Is_Appropriate_For_Record
;
8207 ----------------------
8208 -- Mark_Use_Clauses --
8209 ----------------------
8211 procedure Mark_Use_Clauses
(Id
: Node_Or_Entity_Id
) is
8212 procedure Mark_Parameters
(Call
: Entity_Id
);
8213 -- Perform use_type_clause marking for all parameters in a subprogram
8214 -- or operator call.
8216 procedure Mark_Use_Package
(Pak
: Entity_Id
);
8217 -- Move up the Prev_Use_Clause chain for packages denoted by Pak -
8218 -- marking each clause in the chain as effective in the process.
8220 procedure Mark_Use_Type
(E
: Entity_Id
);
8221 -- Similar to Do_Use_Package_Marking except we move up the
8222 -- Prev_Use_Clause chain for the type denoted by E.
8224 ---------------------
8225 -- Mark_Parameters --
8226 ---------------------
8228 procedure Mark_Parameters
(Call
: Entity_Id
) is
8232 -- Move through all of the formals
8234 Curr
:= First_Formal
(Call
);
8235 while Present
(Curr
) loop
8236 Mark_Use_Type
(Curr
);
8238 Curr
:= Next_Formal
(Curr
);
8241 -- Handle the return type
8243 Mark_Use_Type
(Call
);
8244 end Mark_Parameters
;
8246 ----------------------
8247 -- Mark_Use_Package --
8248 ----------------------
8250 procedure Mark_Use_Package
(Pak
: Entity_Id
) is
8254 -- Ignore cases where the scope of the type is not a package (e.g.
8255 -- Standard_Standard).
8257 if Ekind
(Pak
) /= E_Package
then
8261 Curr
:= Current_Use_Clause
(Pak
);
8262 while Present
(Curr
)
8263 and then not Is_Effective_Use_Clause
(Curr
)
8265 -- We need to mark the previous use clauses as effective, but
8266 -- each use clause may in turn render other use_package_clauses
8267 -- effective. Additionally, it is possible to have a parent
8268 -- package renamed as a child of itself so we must check the
8269 -- prefix entity is not the same as the package we are marking.
8271 if Nkind
(Name
(Curr
)) /= N_Identifier
8272 and then Present
(Prefix
(Name
(Curr
)))
8273 and then Entity
(Prefix
(Name
(Curr
))) /= Pak
8275 Mark_Use_Package
(Entity
(Prefix
(Name
(Curr
))));
8277 -- It is also possible to have a child package without a prefix
8278 -- that relies on a previous use_package_clause.
8280 elsif Nkind
(Name
(Curr
)) = N_Identifier
8281 and then Is_Child_Unit
(Entity
(Name
(Curr
)))
8283 Mark_Use_Package
(Scope
(Entity
(Name
(Curr
))));
8286 -- Mark the use_package_clause as effective and move up the chain
8288 Set_Is_Effective_Use_Clause
(Curr
);
8290 Curr
:= Prev_Use_Clause
(Curr
);
8292 end Mark_Use_Package
;
8298 procedure Mark_Use_Type
(E
: Entity_Id
) is
8302 -- Ignore void types and unresolved string literals and primitives
8304 if Nkind
(E
) = N_String_Literal
8305 or else Nkind
(Etype
(E
)) not in N_Entity
8306 or else not Is_Type
(Etype
(E
))
8311 -- The package containing the type or operator function being used
8312 -- may be in use as well, so mark any use_package_clauses for it as
8313 -- effective. There are also additional sanity checks performed here
8314 -- for ignoring previous errors.
8316 Mark_Use_Package
(Scope
(Base_Type
(Etype
(E
))));
8318 if Nkind
(E
) in N_Op
8319 and then Present
(Entity
(E
))
8320 and then Present
(Scope
(Entity
(E
)))
8322 Mark_Use_Package
(Scope
(Entity
(E
)));
8325 Curr
:= Current_Use_Clause
(Base_Type
(Etype
(E
)));
8326 while Present
(Curr
)
8327 and then not Is_Effective_Use_Clause
(Curr
)
8329 -- Current use_type_clause may render other use_package_clauses
8332 if Nkind
(Subtype_Mark
(Curr
)) /= N_Identifier
8333 and then Present
(Prefix
(Subtype_Mark
(Curr
)))
8335 Mark_Use_Package
(Entity
(Prefix
(Subtype_Mark
(Curr
))));
8338 -- Mark the use_type_clause as effective and move up the chain
8340 Set_Is_Effective_Use_Clause
(Curr
);
8342 Curr
:= Prev_Use_Clause
(Curr
);
8346 -- Start of processing for Mark_Use_Clauses
8349 -- Use clauses in and of themselves do not count as a "use" of a
8352 if Nkind_In
(Parent
(Id
), N_Use_Package_Clause
, N_Use_Type_Clause
) then
8358 if Nkind
(Id
) in N_Entity
then
8360 -- Mark the entity's package
8362 if Is_Potentially_Use_Visible
(Id
) then
8363 Mark_Use_Package
(Scope
(Id
));
8366 -- Mark enumeration literals
8368 if Ekind
(Id
) = E_Enumeration_Literal
then
8373 elsif (Ekind
(Id
) in Overloadable_Kind
8374 or else Ekind_In
(Id
, E_Generic_Function
,
8375 E_Generic_Procedure
))
8376 and then (Is_Potentially_Use_Visible
(Id
)
8377 or else Is_Intrinsic_Subprogram
(Id
))
8379 Mark_Parameters
(Id
);
8387 if Nkind
(Id
) in N_Op
then
8389 -- At this point the left operand may not be resolved if we are
8390 -- encountering multiple operators next to eachother in an
8393 if Nkind
(Id
) in N_Binary_Op
8394 and then not (Nkind
(Left_Opnd
(Id
)) in N_Op
)
8396 Mark_Use_Type
(Left_Opnd
(Id
));
8399 Mark_Use_Type
(Right_Opnd
(Id
));
8402 -- Mark entity identifiers
8404 elsif Nkind
(Id
) in N_Has_Entity
8405 and then (Is_Potentially_Use_Visible
(Entity
(Id
))
8406 or else (Is_Generic_Instance
(Entity
(Id
))
8407 and then Is_Immediately_Visible
(Entity
(Id
))))
8409 -- Ignore fully qualified names as they do not count as a "use" of
8412 if Nkind_In
(Id
, N_Identifier
, N_Operator_Symbol
)
8413 or else (Present
(Prefix
(Id
))
8414 and then Scope
(Entity
(Id
)) /= Entity
(Prefix
(Id
)))
8416 Mark_Use_Clauses
(Entity
(Id
));
8420 end Mark_Use_Clauses
;
8422 --------------------------------
8423 -- Most_Descendant_Use_Clause --
8424 --------------------------------
8426 function Most_Descendant_Use_Clause
8427 (Clause1
: Entity_Id
;
8428 Clause2
: Entity_Id
) return Entity_Id
8430 Scope1
, Scope2
: Entity_Id
;
8433 if Clause1
= Clause2
then
8437 -- We determine which one is the most descendant by the scope distance
8438 -- to the ultimate parent unit.
8440 Scope1
:= Entity_Of_Unit
(Unit
(Parent
(Clause1
)));
8441 Scope2
:= Entity_Of_Unit
(Unit
(Parent
(Clause2
)));
8442 while Scope1
/= Standard_Standard
8443 and then Scope2
/= Standard_Standard
8445 Scope1
:= Scope
(Scope1
);
8446 Scope2
:= Scope
(Scope2
);
8448 if not Present
(Scope1
) then
8450 elsif not Present
(Scope2
) then
8455 if Scope1
= Standard_Standard
then
8460 end Most_Descendant_Use_Clause
;
8466 procedure Pop_Scope
is
8467 SST
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
8468 S
: constant Entity_Id
:= SST
.Entity
;
8471 if Debug_Flag_E
then
8475 -- Set Default_Storage_Pool field of the library unit if necessary
8477 if Ekind_In
(S
, E_Package
, E_Generic_Package
)
8479 Nkind
(Parent
(Unit_Declaration_Node
(S
))) = N_Compilation_Unit
8482 Aux
: constant Node_Id
:=
8483 Aux_Decls_Node
(Parent
(Unit_Declaration_Node
(S
)));
8485 if No
(Default_Storage_Pool
(Aux
)) then
8486 Set_Default_Storage_Pool
(Aux
, Default_Pool
);
8491 Scope_Suppress
:= SST
.Save_Scope_Suppress
;
8492 Local_Suppress_Stack_Top
:= SST
.Save_Local_Suppress_Stack_Top
;
8493 Check_Policy_List
:= SST
.Save_Check_Policy_List
;
8494 Default_Pool
:= SST
.Save_Default_Storage_Pool
;
8495 No_Tagged_Streams
:= SST
.Save_No_Tagged_Streams
;
8496 SPARK_Mode
:= SST
.Save_SPARK_Mode
;
8497 SPARK_Mode_Pragma
:= SST
.Save_SPARK_Mode_Pragma
;
8498 Default_SSO
:= SST
.Save_Default_SSO
;
8499 Uneval_Old
:= SST
.Save_Uneval_Old
;
8501 if Debug_Flag_W
then
8502 Write_Str
("<-- exiting scope: ");
8503 Write_Name
(Chars
(Current_Scope
));
8504 Write_Str
(", Depth=");
8505 Write_Int
(Int
(Scope_Stack
.Last
));
8509 End_Use_Clauses
(SST
.First_Use_Clause
);
8511 -- If the actions to be wrapped are still there they will get lost
8512 -- causing incomplete code to be generated. It is better to abort in
8513 -- this case (and we do the abort even with assertions off since the
8514 -- penalty is incorrect code generation).
8516 if SST
.Actions_To_Be_Wrapped
/= Scope_Actions
'(others => No_List) then
8517 raise Program_Error;
8520 -- Free last subprogram name if allocated, and pop scope
8522 Free (SST.Last_Subprogram_Name);
8523 Scope_Stack.Decrement_Last;
8530 procedure Push_Scope (S : Entity_Id) is
8531 E : constant Entity_Id := Scope (S);
8534 if Ekind (S) = E_Void then
8537 -- Set scope depth if not a non-concurrent type, and we have not yet set
8538 -- the scope depth. This means that we have the first occurrence of the
8539 -- scope, and this is where the depth is set.
8541 elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
8542 and then not Scope_Depth_Set (S)
8544 if S = Standard_Standard then
8545 Set_Scope_Depth_Value (S, Uint_0);
8547 elsif Is_Child_Unit (S) then
8548 Set_Scope_Depth_Value (S, Uint_1);
8550 elsif not Is_Record_Type (Current_Scope) then
8551 if Ekind (S) = E_Loop then
8552 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
8554 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
8559 Scope_Stack.Increment_Last;
8562 SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
8566 SST.Save_Scope_Suppress := Scope_Suppress;
8567 SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top;
8568 SST.Save_Check_Policy_List := Check_Policy_List;
8569 SST.Save_Default_Storage_Pool := Default_Pool;
8570 SST.Save_No_Tagged_Streams := No_Tagged_Streams;
8571 SST.Save_SPARK_Mode := SPARK_Mode;
8572 SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma;
8573 SST.Save_Default_SSO := Default_SSO;
8574 SST.Save_Uneval_Old := Uneval_Old;
8576 -- Each new scope pushed onto the scope stack inherits the component
8577 -- alignment of the previous scope. This emulates the "visibility"
8578 -- semantics of pragma Component_Alignment.
8580 if Scope_Stack.Last > Scope_Stack.First then
8581 SST.Component_Alignment_Default :=
8583 (Scope_Stack.Last - 1). Component_Alignment_Default;
8585 -- Otherwise, this is the first scope being pushed on the scope
8586 -- stack. Inherit the component alignment from the configuration
8587 -- form of pragma Component_Alignment (if any).
8590 SST.Component_Alignment_Default :=
8591 Configuration_Component_Alignment;
8594 SST.Last_Subprogram_Name := null;
8595 SST.Is_Transient := False;
8596 SST.Node_To_Be_Wrapped := Empty;
8597 SST.Pending_Freeze_Actions := No_List;
8598 SST.Actions_To_Be_Wrapped := (others => No_List);
8599 SST.First_Use_Clause := Empty;
8600 SST.Is_Active_Stack_Base := False;
8601 SST.Previous_Visibility := False;
8602 SST.Locked_Shared_Objects := No_Elist;
8605 if Debug_Flag_W then
8606 Write_Str ("--> new scope: ");
8607 Write_Name (Chars (Current_Scope));
8608 Write_Str (", Id=");
8609 Write_Int (Int (Current_Scope));
8610 Write_Str (", Depth=");
8611 Write_Int (Int (Scope_Stack.Last));
8615 -- Deal with copying flags from the previous scope to this one. This is
8616 -- not necessary if either scope is standard, or if the new scope is a
8619 if S /= Standard_Standard
8620 and then Scope (S) /= Standard_Standard
8621 and then not Is_Child_Unit (S)
8623 if Nkind (E) not in N_Entity then
8627 -- Copy categorization flags from Scope (S) to S, this is not done
8628 -- when Scope (S) is Standard_Standard since propagation is from
8629 -- library unit entity inwards. Copy other relevant attributes as
8630 -- well (Discard_Names in particular).
8632 -- We only propagate inwards for library level entities,
8633 -- inner level subprograms do not inherit the categorization.
8635 if Is_Library_Level_Entity (S) then
8636 Set_Is_Preelaborated (S, Is_Preelaborated (E));
8637 Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
8638 Set_Discard_Names (S, Discard_Names (E));
8639 Set_Suppress_Value_Tracking_On_Call
8640 (S, Suppress_Value_Tracking_On_Call (E));
8641 Set_Categorization_From_Scope (E => S, Scop => E);
8645 if Is_Child_Unit (S)
8646 and then Present (E)
8647 and then Ekind_In (E, E_Package, E_Generic_Package)
8649 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
8652 Aux : constant Node_Id :=
8653 Aux_Decls_Node (Parent (Unit_Declaration_Node (E)));
8655 if Present (Default_Storage_Pool (Aux)) then
8656 Default_Pool := Default_Storage_Pool (Aux);
8662 ---------------------
8663 -- Premature_Usage --
8664 ---------------------
8666 procedure Premature_Usage (N : Node_Id) is
8667 Kind : constant Node_Kind := Nkind (Parent (Entity (N)));
8668 E : Entity_Id := Entity (N);
8671 -- Within an instance, the analysis of the actual for a formal object
8672 -- does not see the name of the object itself. This is significant only
8673 -- if the object is an aggregate, where its analysis does not do any
8674 -- name resolution on component associations. (see 4717-008). In such a
8675 -- case, look for the visible homonym on the chain.
8677 if In_Instance and then Present (Homonym (E)) then
8679 while Present (E) and then not In_Open_Scopes (Scope (E)) loop
8685 Set_Etype (N, Etype (E));
8690 if Kind = N_Component_Declaration then
8692 ("component&! cannot be used before end of record declaration", N);
8694 elsif Kind = N_Parameter_Specification then
8696 ("formal parameter&! cannot be used before end of specification",
8699 elsif Kind = N_Discriminant_Specification then
8701 ("discriminant&! cannot be used before end of discriminant part",
8704 elsif Kind = N_Procedure_Specification
8705 or else Kind = N_Function_Specification
8708 ("subprogram&! cannot be used before end of its declaration",
8711 elsif Kind = N_Full_Type_Declaration then
8713 ("type& cannot be used before end of its declaration!", N);
8717 ("object& cannot be used before end of its declaration!", N);
8719 -- If the premature reference appears as the expression in its own
8720 -- declaration, rewrite it to prevent compiler loops in subsequent
8721 -- uses of this mangled declaration in address clauses.
8723 if Nkind (Parent (N)) = N_Object_Declaration then
8724 Set_Entity (N, Any_Id);
8727 end Premature_Usage;
8729 ------------------------
8730 -- Present_System_Aux --
8731 ------------------------
8733 function Present_System_Aux (N : Node_Id := Empty) return Boolean is
8735 Aux_Name : Unit_Name_Type;
8736 Unum : Unit_Number_Type;
8741 function Find_System (C_Unit : Node_Id) return Entity_Id;
8742 -- Scan context clause of compilation unit to find with_clause
8749 function Find_System (C_Unit : Node_Id) return Entity_Id is
8750 With_Clause : Node_Id;
8753 With_Clause := First (Context_Items (C_Unit));
8754 while Present (With_Clause) loop
8755 if (Nkind (With_Clause) = N_With_Clause
8756 and then Chars (Name (With_Clause)) = Name_System)
8757 and then Comes_From_Source (With_Clause)
8768 -- Start of processing for Present_System_Aux
8771 -- The child unit may have been loaded and analyzed already
8773 if Present (System_Aux_Id) then
8776 -- If no previous pragma for System.Aux, nothing to load
8778 elsif No (System_Extend_Unit) then
8781 -- Use the unit name given in the pragma to retrieve the unit.
8782 -- Verify that System itself appears in the context clause of the
8783 -- current compilation. If System is not present, an error will
8784 -- have been reported already.
8787 With_Sys := Find_System (Cunit (Current_Sem_Unit));
8789 The_Unit := Unit (Cunit (Current_Sem_Unit));
8793 (Nkind (The_Unit) = N_Package_Body
8794 or else (Nkind (The_Unit) = N_Subprogram_Body
8795 and then not Acts_As_Spec (Cunit (Current_Sem_Unit))))
8797 With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit)));
8800 if No (With_Sys) and then Present (N) then
8802 -- If we are compiling a subunit, we need to examine its
8803 -- context as well (Current_Sem_Unit is the parent unit);
8805 The_Unit := Parent (N);
8806 while Nkind (The_Unit) /= N_Compilation_Unit loop
8807 The_Unit := Parent (The_Unit);
8810 if Nkind (Unit (The_Unit)) = N_Subunit then
8811 With_Sys := Find_System (The_Unit);
8815 if No (With_Sys) then
8819 Loc := Sloc (With_Sys);
8820 Get_Name_String (Chars (Expression (System_Extend_Unit)));
8821 Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
8822 Name_Buffer (1 .. 7) := "system.";
8823 Name_Buffer (Name_Len + 8) := '%';
8824 Name_Buffer (Name_Len + 9) := 's
';
8825 Name_Len := Name_Len + 9;
8826 Aux_Name := Name_Find;
8830 (Load_Name => Aux_Name,
8833 Error_Node => With_Sys);
8835 if Unum /= No_Unit then
8836 Semantics (Cunit (Unum));
8838 Defining_Entity (Specification (Unit (Cunit (Unum))));
8841 Make_With_Clause (Loc,
8843 Make_Expanded_Name (Loc,
8844 Chars => Chars (System_Aux_Id),
8845 Prefix => New_Occurrence_Of (Scope (System_Aux_Id), Loc),
8846 Selector_Name => New_Occurrence_Of (System_Aux_Id, Loc)));
8848 Set_Entity (Name (Withn), System_Aux_Id);
8850 Set_Library_Unit (Withn, Cunit (Unum));
8851 Set_Corresponding_Spec (Withn, System_Aux_Id);
8852 Set_First_Name (Withn, True);
8853 Set_Implicit_With (Withn, True);
8855 Insert_After (With_Sys, Withn);
8856 Mark_Rewrite_Insertion (Withn);
8857 Set_Context_Installed (Withn);
8861 -- Here if unit load failed
8864 Error_Msg_Name_1 := Name_System;
8865 Error_Msg_Name_2 := Chars (Expression (System_Extend_Unit));
8867 ("extension package `%.%` does not exist",
8868 Opt.System_Extend_Unit);
8872 end Present_System_Aux;
8874 -------------------------
8875 -- Restore_Scope_Stack --
8876 -------------------------
8878 procedure Restore_Scope_Stack
8880 Handle_Use : Boolean := True)
8882 SS_Last : constant Int := Scope_Stack.Last;
8886 -- Restore visibility of previous scope stack, if any, using the list
8887 -- we saved (we use Remove, since this list will not be used again).
8890 Elmt := Last_Elmt (List);
8891 exit when Elmt = No_Elmt;
8892 Set_Is_Immediately_Visible (Node (Elmt));
8893 Remove_Last_Elmt (List);
8896 -- Restore use clauses
8898 if SS_Last >= Scope_Stack.First
8899 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
8903 (Scope_Stack.Table (SS_Last).First_Use_Clause,
8904 Force_Installation => True);
8906 end Restore_Scope_Stack;
8908 ----------------------
8909 -- Save_Scope_Stack --
8910 ----------------------
8912 -- Save_Scope_Stack/Restore_Scope_Stack were originally designed to avoid
8913 -- consuming any memory. That is, Save_Scope_Stack took care of removing
8914 -- from immediate visibility entities and Restore_Scope_Stack took care
8915 -- of restoring their visibility analyzing the context of each entity. The
8916 -- problem of such approach is that it was fragile and caused unexpected
8917 -- visibility problems, and indeed one test was found where there was a
8920 -- Furthermore, the following experiment was carried out:
8922 -- - Save_Scope_Stack was modified to store in an Elist1 all those
8923 -- entities whose attribute Is_Immediately_Visible is modified
8924 -- from True to False.
8926 -- - Restore_Scope_Stack was modified to store in another Elist2
8927 -- all the entities whose attribute Is_Immediately_Visible is
8928 -- modified from False to True.
8930 -- - Extra code was added to verify that all the elements of Elist1
8931 -- are found in Elist2
8933 -- This test shows that there may be more occurrences of this problem which
8934 -- have not yet been detected. As a result, we replaced that approach by
8935 -- the current one in which Save_Scope_Stack returns the list of entities
8936 -- whose visibility is changed, and that list is passed to Restore_Scope_
8937 -- Stack to undo that change. This approach is simpler and safer, although
8938 -- it consumes more memory.
8940 function Save_Scope_Stack (Handle_Use : Boolean := True) return Elist_Id is
8941 Result : constant Elist_Id := New_Elmt_List;
8944 SS_Last : constant Int := Scope_Stack.Last;
8946 procedure Remove_From_Visibility (E : Entity_Id);
8947 -- If E is immediately visible then append it to the result and remove
8948 -- it temporarily from visibility.
8950 ----------------------------
8951 -- Remove_From_Visibility --
8952 ----------------------------
8954 procedure Remove_From_Visibility (E : Entity_Id) is
8956 if Is_Immediately_Visible (E) then
8957 Append_Elmt (E, Result);
8958 Set_Is_Immediately_Visible (E, False);
8960 end Remove_From_Visibility;
8962 -- Start of processing for Save_Scope_Stack
8965 if SS_Last >= Scope_Stack.First
8966 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
8969 End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
8972 -- If the call is from within a compilation unit, as when called from
8973 -- Rtsfind, make current entries in scope stack invisible while we
8974 -- analyze the new unit.
8976 for J in reverse 0 .. SS_Last loop
8977 exit when Scope_Stack.Table (J).Entity = Standard_Standard
8978 or else No (Scope_Stack.Table (J).Entity);
8980 S := Scope_Stack.Table (J).Entity;
8982 Remove_From_Visibility (S);
8984 E := First_Entity (S);
8985 while Present (E) loop
8986 Remove_From_Visibility (E);
8994 end Save_Scope_Stack;
9000 procedure Set_Use (L : List_Id) is
9006 while Present (Decl) loop
9007 if Nkind (Decl) = N_Use_Package_Clause then
9008 Chain_Use_Clause (Decl);
9009 Use_One_Package (Decl, Name (Decl));
9011 elsif Nkind (Decl) = N_Use_Type_Clause then
9012 Chain_Use_Clause (Decl);
9013 Use_One_Type (Subtype_Mark (Decl));
9022 -----------------------------
9023 -- Update_Use_Clause_Chain --
9024 -----------------------------
9026 procedure Update_Use_Clause_Chain is
9027 procedure Update_Chain_In_Scope (Level : Int);
9028 -- Iterate through one level in the scope stack verifying each use-type
9029 -- clause within said level is used then reset the Current_Use_Clause
9030 -- to a redundant use clause outside of the current ending scope if such
9033 ---------------------------
9034 -- Update_Chain_In_Scope --
9035 ---------------------------
9037 procedure Update_Chain_In_Scope (Level : Int) is
9042 -- Loop through all use clauses within the scope dictated by Level
9044 Curr := Scope_Stack.Table (Level).First_Use_Clause;
9045 while Present (Curr) loop
9047 -- Retrieve the subtype mark or name within the current current
9050 if Nkind (Curr) = N_Use_Type_Clause then
9051 N := Subtype_Mark (Curr);
9056 -- If warnings for unreferenced entities are enabled and the
9057 -- current use clause has not been marked effective.
9059 if Check_Unreferenced
9060 and then Comes_From_Source (Curr)
9061 and then not Is_Effective_Use_Clause (Curr)
9062 and then not In_Instance
9064 -- We are dealing with a potentially unused use_package_clause
9066 if Nkind (Curr) = N_Use_Package_Clause then
9068 -- Renamings and formal subprograms may cause the associated
9069 -- to be marked as effective instead of the original.
9071 if not (Present (Associated_Node (N))
9074 (Associated_Node (N)))
9075 and then Is_Effective_Use_Clause
9077 (Associated_Node (N))))
9079 Error_Msg_Node_1 := Entity (N);
9081 ("use clause for package &? has no effect",
9085 -- We are dealing with an unused use_type_clause
9088 Error_Msg_Node_1 := Etype (N);
9090 ("use clause for }? has no effect", Curr, Etype (N));
9094 -- Verify that we haven't already processed a redundant
9095 -- use_type_clause within the same scope before we move the
9096 -- current use clause up to a previous one for type T.
9098 if Present (Prev_Use_Clause (Curr)) then
9099 Set_Current_Use_Clause (Entity (N), Prev_Use_Clause (Curr));
9102 Curr := Next_Use_Clause (Curr);
9104 end Update_Chain_In_Scope;
9106 -- Start of processing for Update_Use_Clause_Chain
9109 Update_Chain_In_Scope (Scope_Stack.Last);
9111 -- Deal with use clauses within the context area if the current
9112 -- scope is a compilation unit.
9114 if Is_Compilation_Unit (Current_Scope) then
9116 pragma Assert (Scope_Stack.Last /= Scope_Stack.First);
9118 Update_Chain_In_Scope (Scope_Stack.Last - 1);
9120 end Update_Use_Clause_Chain;
9122 ---------------------
9123 -- Use_One_Package --
9124 ---------------------
9126 procedure Use_One_Package
9128 Pack_Name : Entity_Id := Empty;
9129 Force : Boolean := False)
9131 procedure Note_Redundant_Use (Clause : Node_Id);
9132 -- Mark the name in a use clause as redundant if the corresponding
9133 -- entity is already use-visible. Emit a warning if the use clause comes
9134 -- from source and the proper warnings are enabled.
9136 ------------------------
9137 -- Note_Redundant_Use --
9138 ------------------------
9140 procedure Note_Redundant_Use (Clause : Node_Id) is
9141 Decl : constant Node_Id := Parent (Clause);
9142 Pack_Name : constant Entity_Id := Entity (Clause);
9144 Cur_Use : Node_Id := Current_Use_Clause (Pack_Name);
9145 Prev_Use : Node_Id := Empty;
9146 Redundant : Node_Id := Empty;
9147 -- The Use_Clause which is actually redundant. In the simplest case
9148 -- it is Pack itself, but when we compile a body we install its
9149 -- context before that of its spec, in which case it is the
9150 -- use_clause in the spec that will appear to be redundant, and we
9151 -- want the warning to be placed on the body. Similar complications
9152 -- appear when the redundancy is between a child unit and one of its
9156 -- Could be renamed...
9158 if No (Cur_Use) then
9159 Cur_Use := Current_Use_Clause (Renamed_Entity (Pack_Name));
9162 Set_Redundant_Use (Clause, True);
9164 if not Comes_From_Source (Clause)
9166 or else not Warn_On_Redundant_Constructs
9171 if not Is_Compilation_Unit (Current_Scope) then
9173 -- If the use_clause is in an inner scope, it is made redundant by
9174 -- some clause in the current context, with one exception: If we
9175 -- are compiling a nested package body, and the use_clause comes
9176 -- from then corresponding spec, the clause is not necessarily
9177 -- fully redundant, so we should not warn. If a warning was
9178 -- warranted, it would have been given when the spec was
9181 if Nkind (Parent (Decl)) = N_Package_Specification then
9183 Package_Spec_Entity : constant Entity_Id :=
9184 Defining_Unit_Name (Parent (Decl));
9186 if In_Package_Body (Package_Spec_Entity) then
9192 Redundant := Clause;
9193 Prev_Use := Cur_Use;
9195 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
9197 Cur_Unit : constant Unit_Number_Type :=
9198 Get_Source_Unit (Cur_Use);
9199 New_Unit : constant Unit_Number_Type :=
9200 Get_Source_Unit (Clause);
9205 if Cur_Unit = New_Unit then
9207 -- Redundant clause in same body
9209 Redundant := Clause;
9210 Prev_Use := Cur_Use;
9212 elsif Cur_Unit = Current_Sem_Unit then
9214 -- If the new clause is not in the current unit it has been
9215 -- analyzed first, and it makes the other one redundant.
9216 -- However, if the new clause appears in a subunit, Cur_Unit
9217 -- is still the parent, and in that case the redundant one
9218 -- is the one appearing in the subunit.
9220 if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then
9221 Redundant := Clause;
9222 Prev_Use := Cur_Use;
9224 -- Most common case: redundant clause in body, original
9225 -- clause in spec. Current scope is spec entity.
9227 elsif Current_Scope = Cunit_Entity (Current_Sem_Unit) then
9228 Redundant := Cur_Use;
9232 -- The new clause may appear in an unrelated unit, when
9233 -- the parents of a generic are being installed prior to
9234 -- instantiation. In this case there must be no warning.
9235 -- We detect this case by checking whether the current
9236 -- top of the stack is related to the current
9239 Scop := Current_Scope;
9240 while Present (Scop)
9241 and then Scop /= Standard_Standard
9243 if Is_Compilation_Unit (Scop)
9244 and then not Is_Child_Unit (Scop)
9248 elsif Scop = Cunit_Entity (Current_Sem_Unit) then
9252 Scop := Scope (Scop);
9255 Redundant := Cur_Use;
9259 elsif New_Unit = Current_Sem_Unit then
9260 Redundant := Clause;
9261 Prev_Use := Cur_Use;
9264 -- Neither is the current unit, so they appear in parent or
9265 -- sibling units. Warning will be emitted elsewhere.
9271 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
9272 and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit))))
9274 -- Use_clause is in child unit of current unit, and the child unit
9275 -- appears in the context of the body of the parent, so it has
9276 -- been installed first, even though it is the redundant one.
9277 -- Depending on their placement in the context, the visible or the
9278 -- private parts of the two units, either might appear as
9279 -- redundant, but the message has to be on the current unit.
9281 if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then
9282 Redundant := Cur_Use;
9285 Redundant := Clause;
9286 Prev_Use := Cur_Use;
9289 -- If the new use clause appears in the private part of a parent
9290 -- unit it may appear to be redundant w.r.t. a use clause in a
9291 -- child unit, but the previous use clause was needed in the
9292 -- visible part of the child, and no warning should be emitted.
9294 if Nkind (Parent (Decl)) = N_Package_Specification
9295 and then List_Containing (Decl) =
9296 Private_Declarations (Parent (Decl))
9299 Par : constant Entity_Id := Defining_Entity (Parent (Decl));
9300 Spec : constant Node_Id :=
9301 Specification (Unit (Cunit (Current_Sem_Unit)));
9304 if Is_Compilation_Unit (Par)
9305 and then Par /= Cunit_Entity (Current_Sem_Unit)
9306 and then Parent (Cur_Use) = Spec
9307 and then List_Containing (Cur_Use) =
9308 Visible_Declarations (Spec)
9315 -- Finally, if the current use clause is in the context then the
9316 -- clause is redundant when it is nested within the unit.
9318 elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit
9319 and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit
9320 and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause)
9322 Redundant := Clause;
9323 Prev_Use := Cur_Use;
9327 if Present (Redundant) and then Parent (Redundant) /= Prev_Use then
9329 -- Make sure we are looking at most-descendant use_package_clause
9330 -- by traversing the chain with Find_Most_Prev and then verifying
9331 -- there is no scope manipulation via Most_Descendant_Use_Clause.
9333 if Nkind (Prev_Use) = N_Use_Package_Clause
9335 (Nkind (Parent (Prev_Use)) /= N_Compilation_Unit
9336 or else Most_Descendant_Use_Clause
9337 (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use)
9339 Prev_Use := Find_Most_Prev (Prev_Use);
9342 Error_Msg_Sloc := Sloc (Prev_Use);
9343 Error_Msg_NE -- CODEFIX
9344 ("& is already use-visible through previous use_clause #??",
9345 Redundant, Pack_Name);
9347 end Note_Redundant_Use;
9351 Current_Instance : Entity_Id := Empty;
9355 Private_With_OK : Boolean := False;
9358 -- Start of processing for Use_One_Package
9361 -- Use_One_Package may have been called recursively to handle an
9362 -- implicit use for a auxiliary system package, so set P accordingly
9363 -- and skip redundancy checks.
9365 if No (Pack_Name) and then Present_System_Aux (N) then
9368 -- Check for redundant use_package_clauses
9371 -- Ignore cases where we are dealing with a non user defined package
9372 -- like Standard_Standard or something other than a valid package.
9374 if not Is_Entity_Name (Pack_Name)
9375 or else No (Entity (Pack_Name))
9376 or else Ekind (Entity (Pack_Name)) /= E_Package
9381 -- When a renaming exists we must check it for redundancy. The
9382 -- original package would have already been seen at this point.
9384 if Present (Renamed_Object (Entity (Pack_Name))) then
9385 P := Renamed_Object (Entity (Pack_Name));
9387 P := Entity (Pack_Name);
9390 -- Check for redundant clauses then set the current use clause for
9391 -- P if were are not "forcing" an installation from a scope
9392 -- reinstallation that is done throughout analysis for various
9396 Note_Redundant_Use (Pack_Name);
9399 Set_Current_Use_Clause (P, N);
9404 -- Warn about detected redundant clauses
9406 elsif In_Open_Scopes (P) and not Force then
9407 if Warn_On_Redundant_Constructs and then P = Current_Scope then
9408 Error_Msg_NE -- CODEFIX
9409 ("& is already use-visible within itself?r?",
9416 -- Set P back to the non-renamed package so that visiblilty of the
9417 -- entities within the package can be properly set below.
9419 P := Entity (Pack_Name);
9423 Set_Current_Use_Clause (P, N);
9425 -- Ada 2005 (AI-50217): Check restriction
9427 if From_Limited_With (P) then
9428 Error_Msg_N ("limited withed package cannot appear in use clause", N);
9431 -- Find enclosing instance, if any
9434 Current_Instance := Current_Scope;
9435 while not Is_Generic_Instance (Current_Instance) loop
9436 Current_Instance := Scope (Current_Instance);
9439 if No (Hidden_By_Use_Clause (N)) then
9440 Set_Hidden_By_Use_Clause (N, New_Elmt_List);
9444 -- If unit is a package renaming, indicate that the renamed package is
9445 -- also in use (the flags on both entities must remain consistent, and a
9446 -- subsequent use of either of them should be recognized as redundant).
9448 if Present (Renamed_Object (P)) then
9449 Set_In_Use (Renamed_Object (P));
9450 Set_Current_Use_Clause (Renamed_Object (P), N);
9451 Real_P := Renamed_Object (P);
9456 -- Ada 2005 (AI-262): Check the use_clause of a private withed package
9457 -- found in the private part of a package specification
9459 if In_Private_Part (Current_Scope)
9460 and then Has_Private_With (P)
9461 and then Is_Child_Unit (Current_Scope)
9462 and then Is_Child_Unit (P)
9463 and then Is_Ancestor_Package (Scope (Current_Scope), P)
9465 Private_With_OK := True;
9468 -- Loop through entities in one package making them potentially
9471 Id := First_Entity (P);
9473 and then (Id /= First_Private_Entity (P)
9474 or else Private_With_OK) -- Ada 2005 (AI-262)
9476 Prev := Current_Entity (Id);
9477 while Present (Prev) loop
9478 if Is_Immediately_Visible (Prev)
9479 and then (not Is_Overloadable (Prev)
9480 or else not Is_Overloadable (Id)
9481 or else (Type_Conformant (Id, Prev)))
9483 if No (Current_Instance) then
9485 -- Potentially use-visible entity remains hidden
9487 goto Next_Usable_Entity;
9489 -- A use clause within an instance hides outer global entities,
9490 -- which are not used to resolve local entities in the
9491 -- instance. Note that the predefined entities in Standard
9492 -- could not have been hidden in the generic by a use clause,
9493 -- and therefore remain visible. Other compilation units whose
9494 -- entities appear in Standard must be hidden in an instance.
9496 -- To determine whether an entity is external to the instance
9497 -- we compare the scope depth of its scope with that of the
9498 -- current instance. However, a generic actual of a subprogram
9499 -- instance is declared in the wrapper package but will not be
9500 -- hidden by a use-visible entity. similarly, an entity that is
9501 -- declared in an enclosing instance will not be hidden by an
9502 -- an entity declared in a generic actual, which can only have
9503 -- been use-visible in the generic and will not have hidden the
9504 -- entity in the generic parent.
9506 -- If Id is called Standard, the predefined package with the
9507 -- same name is in the homonym chain. It has to be ignored
9508 -- because it has no defined scope (being the only entity in
9509 -- the system with this mandated behavior).
9511 elsif not Is_Hidden (Id)
9512 and then Present (Scope (Prev))
9513 and then not Is_Wrapper_Package (Scope (Prev))
9514 and then Scope_Depth (Scope (Prev)) <
9515 Scope_Depth (Current_Instance)
9516 and then (Scope (Prev) /= Standard_Standard
9517 or else Sloc (Prev) > Standard_Location)
9519 if In_Open_Scopes (Scope (Prev))
9520 and then Is_Generic_Instance (Scope (Prev))
9521 and then Present (Associated_Formal_Package (P))
9526 Set_Is_Potentially_Use_Visible (Id);
9527 Set_Is_Immediately_Visible (Prev, False);
9528 Append_Elmt (Prev, Hidden_By_Use_Clause (N));
9532 -- A user-defined operator is not use-visible if the predefined
9533 -- operator for the type is immediately visible, which is the case
9534 -- if the type of the operand is in an open scope. This does not
9535 -- apply to user-defined operators that have operands of different
9536 -- types, because the predefined mixed mode operations (multiply
9537 -- and divide) apply to universal types and do not hide anything.
9539 elsif Ekind (Prev) = E_Operator
9540 and then Operator_Matches_Spec (Prev, Id)
9541 and then In_Open_Scopes
9542 (Scope (Base_Type (Etype (First_Formal (Id)))))
9543 and then (No (Next_Formal (First_Formal (Id)))
9544 or else Etype (First_Formal (Id)) =
9545 Etype (Next_Formal (First_Formal (Id)))
9546 or else Chars (Prev) = Name_Op_Expon)
9548 goto Next_Usable_Entity;
9550 -- In an instance, two homonyms may become use_visible through the
9551 -- actuals of distinct formal packages. In the generic, only the
9552 -- current one would have been visible, so make the other one
9555 elsif Present (Current_Instance)
9556 and then Is_Potentially_Use_Visible (Prev)
9557 and then not Is_Overloadable (Prev)
9558 and then Scope (Id) /= Scope (Prev)
9559 and then Used_As_Generic_Actual (Scope (Prev))
9560 and then Used_As_Generic_Actual (Scope (Id))
9561 and then not In_Same_List (Current_Use_Clause (Scope (Prev)),
9562 Current_Use_Clause (Scope (Id)))
9564 Set_Is_Potentially_Use_Visible (Prev, False);
9565 Append_Elmt (Prev, Hidden_By_Use_Clause (N));
9568 Prev := Homonym (Prev);
9571 -- On exit, we know entity is not hidden, unless it is private
9573 if not Is_Hidden (Id)
9574 and then ((not Is_Child_Unit (Id)) or else Is_Visible_Lib_Unit (Id))
9576 Set_Is_Potentially_Use_Visible (Id);
9578 if Is_Private_Type (Id) and then Present (Full_View (Id)) then
9579 Set_Is_Potentially_Use_Visible (Full_View (Id));
9583 <<Next_Usable_Entity>>
9587 -- Child units are also made use-visible by a use clause, but they may
9588 -- appear after all visible declarations in the parent entity list.
9590 while Present (Id) loop
9591 if Is_Child_Unit (Id) and then Is_Visible_Lib_Unit (Id) then
9592 Set_Is_Potentially_Use_Visible (Id);
9598 if Chars (Real_P) = Name_System
9599 and then Scope (Real_P) = Standard_Standard
9600 and then Present_System_Aux (N)
9602 Use_One_Package (N);
9604 end Use_One_Package;
9610 procedure Use_One_Type
9612 Installed : Boolean := False;
9613 Force : Boolean := False)
9615 function Spec_Reloaded_For_Body return Boolean;
9616 -- Determine whether the compilation unit is a package body and the use
9617 -- type clause is in the spec of the same package. Even though the spec
9618 -- was analyzed first, its context is reloaded when analysing the body.
9620 procedure Use_Class_Wide_Operations (Typ : Entity_Id);
9621 -- AI05-150: if the use_type_clause carries the "all" qualifier,
9622 -- class-wide operations of ancestor types are use-visible if the
9623 -- ancestor type is visible.
9625 ----------------------------
9626 -- Spec_Reloaded_For_Body --
9627 ----------------------------
9629 function Spec_Reloaded_For_Body return Boolean is
9631 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
9633 Spec : constant Node_Id :=
9634 Parent (List_Containing (Parent (Id)));
9637 -- Check whether type is declared in a package specification,
9638 -- and current unit is the corresponding package body. The
9639 -- use clauses themselves may be within a nested package.
9642 Nkind (Spec) = N_Package_Specification
9643 and then In_Same_Source_Unit
9644 (Corresponding_Body (Parent (Spec)),
9645 Cunit_Entity (Current_Sem_Unit));
9650 end Spec_Reloaded_For_Body;
9652 -------------------------------
9653 -- Use_Class_Wide_Operations --
9654 -------------------------------
9656 procedure Use_Class_Wide_Operations (Typ : Entity_Id) is
9657 function Is_Class_Wide_Operation_Of
9659 T : Entity_Id) return Boolean;
9660 -- Determine whether a subprogram has a class-wide parameter or
9661 -- result that is T'Class.
9663 ---------------------------------
9664 -- Is_Class_Wide_Operation_Of --
9665 ---------------------------------
9667 function Is_Class_Wide_Operation_Of
9669 T : Entity_Id) return Boolean
9674 Formal := First_Formal (Op);
9675 while Present (Formal) loop
9676 if Etype (Formal) = Class_Wide_Type (T) then
9680 Next_Formal (Formal);
9683 if Etype (Op) = Class_Wide_Type (T) then
9688 end Is_Class_Wide_Operation_Of;
9695 -- Start of processing for Use_Class_Wide_Operations
9698 Scop := Scope (Typ);
9699 if not Is_Hidden (Scop) then
9700 Ent := First_Entity (Scop);
9701 while Present (Ent) loop
9702 if Is_Overloadable (Ent)
9703 and then Is_Class_Wide_Operation_Of (Ent, Typ)
9704 and then not Is_Potentially_Use_Visible (Ent)
9706 Set_Is_Potentially_Use_Visible (Ent);
9707 Append_Elmt (Ent, Used_Operations (Parent (Id)));
9714 if Is_Derived_Type (Typ) then
9715 Use_Class_Wide_Operations (Etype (Base_Type (Typ)));
9717 end Use_Class_Wide_Operations;
9722 Is_Known_Used : Boolean;
9726 -- Start of processing for Use_One_Type
9729 if Entity (Id) = Any_Type then
9733 -- It is the type determined by the subtype mark (8.4(8)) whose
9734 -- operations become potentially use-visible.
9736 T := Base_Type (Entity (Id));
9738 -- Either the type itself is used, the package where it is declared is
9739 -- in use or the entity is declared in the current package, thus
9744 and then ((Present (Current_Use_Clause (T))
9745 and then All_Present (Current_Use_Clause (T)))
9746 or else not All_Present (Parent (Id))))
9747 or else In_Use (Scope (T))
9748 or else Scope (T) = Current_Scope;
9750 Set_Redundant_Use (Id,
9751 Is_Known_Used or else Is_Potentially_Use_Visible (T));
9753 if Ekind (T) = E_Incomplete_Type then
9754 Error_Msg_N ("premature usage of incomplete type", Id);
9756 elsif In_Open_Scopes (Scope (T)) then
9759 -- A limited view cannot appear in a use_type_clause. However, an access
9760 -- type whose designated type is limited has the flag but is not itself
9761 -- a limited view unless we only have a limited view of its enclosing
9764 elsif From_Limited_With (T) and then From_Limited_With (Scope (T)) then
9766 ("incomplete type from limited view cannot appear in use clause",
9769 -- If the use clause is redundant, Used_Operations will usually be
9770 -- empty, but we need to set it to empty here in one case: If we are
9771 -- instantiating a generic library unit, then we install the ancestors
9772 -- of that unit in the scope stack, which involves reprocessing use
9773 -- clauses in those ancestors. Such a use clause will typically have a
9774 -- nonempty Used_Operations unless it was redundant in the generic unit,
9775 -- even if it is redundant at the place of the instantiation.
9777 elsif Redundant_Use (Id) then
9779 -- We must avoid incorrectly setting the Current_Use_Clause when we
9780 -- are working with a redundant clause that has already been linked
9781 -- in the Prev_Use_Clause chain, otherwise the chain will break.
9783 if Present (Current_Use_Clause (T))
9784 and then Present (Prev_Use_Clause (Current_Use_Clause (T)))
9785 and then Parent (Id) = Prev_Use_Clause (Current_Use_Clause (T))
9789 Set_Current_Use_Clause (T, Parent (Id));
9792 Set_Used_Operations (Parent (Id), New_Elmt_List);
9794 -- If the subtype mark designates a subtype in a different package,
9795 -- we have to check that the parent type is visible, otherwise the
9796 -- use_type_clause is a no-op. Not clear how to do that???
9799 Set_Current_Use_Clause (T, Parent (Id));
9802 -- If T is tagged, primitive operators on class-wide operands are
9805 if Is_Tagged_Type (T) then
9806 Set_In_Use (Class_Wide_Type (T));
9809 -- Iterate over primitive operations of the type. If an operation is
9810 -- already use_visible, it is the result of a previous use_clause,
9811 -- and already appears on the corresponding entity chain. If the
9812 -- clause is being reinstalled, operations are already use-visible.
9818 Op_List := Collect_Primitive_Operations (T);
9819 Elmt := First_Elmt (Op_List);
9820 while Present (Elmt) loop
9821 if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol
9822 or else Chars (Node (Elmt)) in Any_Operator_Name)
9823 and then not Is_Hidden (Node (Elmt))
9824 and then not Is_Potentially_Use_Visible (Node (Elmt))
9826 Set_Is_Potentially_Use_Visible (Node (Elmt));
9827 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id)));
9829 elsif Ada_Version >= Ada_2012
9830 and then All_Present (Parent (Id))
9831 and then not Is_Hidden (Node (Elmt))
9832 and then not Is_Potentially_Use_Visible (Node (Elmt))
9834 Set_Is_Potentially_Use_Visible (Node (Elmt));
9835 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id)));
9842 if Ada_Version >= Ada_2012
9843 and then All_Present (Parent (Id))
9844 and then Is_Tagged_Type (T)
9846 Use_Class_Wide_Operations (T);
9850 -- If warning on redundant constructs, check for unnecessary WITH
9853 and then Warn_On_Redundant_Constructs
9854 and then Is_Known_Used
9856 -- with P; with P; use P;
9857 -- package P is package X is package body X is
9858 -- type T ... use P.T;
9860 -- The compilation unit is the body of X. GNAT first compiles the
9861 -- spec of X, then proceeds to the body. At that point P is marked
9862 -- as use visible. The analysis then reinstalls the spec along with
9863 -- its context. The use clause P.T is now recognized as redundant,
9864 -- but in the wrong context. Do not emit a warning in such cases.
9865 -- Do not emit a warning either if we are in an instance, there is
9866 -- no redundancy between an outer use_clause and one that appears
9867 -- within the generic.
9869 and then not Spec_Reloaded_For_Body
9870 and then not In_Instance
9872 -- The type already has a use clause
9876 -- Case where we know the current use clause for the type
9878 if Present (Current_Use_Clause (T)) then
9879 Use_Clause_Known : declare
9880 Clause1 : constant Node_Id :=
9881 Find_Most_Prev (Current_Use_Clause (T));
9882 Clause2 : constant Node_Id := Parent (Id);
9889 -- Start of processing for Use_Clause_Known
9892 -- If both current use_type_clause and the use_type_clause
9893 -- for the type are at the compilation unit level, one of
9894 -- the units must be an ancestor of the other, and the
9895 -- warning belongs on the descendant.
9897 if Nkind (Parent (Clause1)) = N_Compilation_Unit
9899 Nkind (Parent (Clause2)) = N_Compilation_Unit
9901 -- If the unit is a subprogram body that acts as spec,
9902 -- the context clause is shared with the constructed
9903 -- subprogram spec. Clearly there is no redundancy.
9905 if Clause1 = Clause2 then
9909 Unit1 := Unit (Parent (Clause1));
9910 Unit2 := Unit (Parent (Clause2));
9912 -- If both clauses are on same unit, or one is the body
9913 -- of the other, or one of them is in a subunit, report
9914 -- redundancy on the later one.
9916 if Unit1 = Unit2 or else Nkind (Unit1) = N_Subunit then
9917 Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
9918 Error_Msg_NE -- CODEFIX
9919 ("& is already use-visible through previous "
9920 & "use_type_clause #??", Clause1, T);
9923 elsif Nkind_In (Unit2, N_Package_Body, N_Subprogram_Body)
9924 and then Nkind (Unit1) /= Nkind (Unit2)
9925 and then Nkind (Unit1) /= N_Subunit
9927 Error_Msg_Sloc := Sloc (Clause1);
9928 Error_Msg_NE -- CODEFIX
9929 ("& is already use-visible through previous "
9930 & "use_type_clause #??", Current_Use_Clause (T), T);
9934 -- There is a redundant use_type_clause in a child unit.
9935 -- Determine which of the units is more deeply nested.
9936 -- If a unit is a package instance, retrieve the entity
9937 -- and its scope from the instance spec.
9939 Ent1 := Entity_Of_Unit (Unit1);
9940 Ent2 := Entity_Of_Unit (Unit2);
9942 if Scope (Ent2) = Standard_Standard then
9943 Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
9946 elsif Scope (Ent1) = Standard_Standard then
9947 Error_Msg_Sloc := Sloc (Id);
9950 -- If both units are child units, we determine which one
9951 -- is the descendant by the scope distance to the
9952 -- ultimate parent unit.
9963 and then Present (S2)
9964 and then S1 /= Standard_Standard
9965 and then S2 /= Standard_Standard
9971 if S1 = Standard_Standard then
9972 Error_Msg_Sloc := Sloc (Id);
9975 Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
9981 if Parent (Id) /= Err_No then
9982 if Most_Descendant_Use_Clause
9983 (Err_No, Parent (Id)) = Parent (Id)
9985 Error_Msg_Sloc := Sloc (Err_No);
9986 Err_No := Parent (Id);
9989 Error_Msg_NE -- CODEFIX
9990 ("& is already use-visible through previous "
9991 & "use_type_clause #??", Err_No, Id);
9994 -- Case where current use_type_clause and use_type_clause
9995 -- for the type are not both at the compilation unit level.
9996 -- In this case we don't have location information.
9999 Error_Msg_NE -- CODEFIX
10000 ("& is already use-visible through previous "
10001 & "use_type_clause??", Id, T);
10003 end Use_Clause_Known;
10005 -- Here if Current_Use_Clause is not set for T, another case where
10006 -- we do not have the location information available.
10009 Error_Msg_NE -- CODEFIX
10010 ("& is already use-visible through previous "
10011 & "use_type_clause??", Id, T);
10014 -- The package where T is declared is already used
10016 elsif In_Use (Scope (T)) then
10018 Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T))));
10019 Error_Msg_NE -- CODEFIX
10020 ("& is already use-visible through package use clause #??",
10023 -- The current scope is the package where T is declared
10026 Error_Msg_Node_2 := Scope (T);
10027 Error_Msg_NE -- CODEFIX
10028 ("& is already use-visible inside package &??", Id, T);
10037 procedure Write_Info is
10038 Id : Entity_Id := First_Entity (Current_Scope);
10041 -- No point in dumping standard entities
10043 if Current_Scope = Standard_Standard then
10047 Write_Str ("========================================================");
10049 Write_Str (" Defined Entities in ");
10050 Write_Name (Chars (Current_Scope));
10052 Write_Str ("========================================================");
10056 Write_Str ("-- none --");
10060 while Present (Id) loop
10061 Write_Entity_Info (Id, " ");
10066 if Scope (Current_Scope) = Standard_Standard then
10068 -- Print information on the current unit itself
10070 Write_Entity_Info (Current_Scope, " ");
10083 for J in reverse 1 .. Scope_Stack.Last loop
10084 S := Scope_Stack.Table (J).Entity;
10085 Write_Int (Int (S));
10086 Write_Str (" === ");
10087 Write_Name (Chars (S));
10096 procedure we (S : Entity_Id) is
10099 E := First_Entity (S);
10100 while Present (E) loop
10101 Write_Int (Int (E));
10102 Write_Str (" === ");
10103 Write_Name (Chars (E));