OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [sem_ch8.adb] - Blame information for rev 281

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              S E M . C H 8                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
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.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Debug;    use Debug;
28
with Einfo;    use Einfo;
29
with Elists;   use Elists;
30
with Errout;   use Errout;
31
with Exp_Tss;  use Exp_Tss;
32
with Exp_Util; use Exp_Util;
33
with Fname;    use Fname;
34
with Freeze;   use Freeze;
35
with Impunit;  use Impunit;
36
with Lib;      use Lib;
37
with Lib.Load; use Lib.Load;
38
with Lib.Xref; use Lib.Xref;
39
with Namet;    use Namet;
40
with Namet.Sp; use Namet.Sp;
41
with Nlists;   use Nlists;
42
with Nmake;    use Nmake;
43
with Opt;      use Opt;
44
with Output;   use Output;
45
with Restrict; use Restrict;
46
with Rident;   use Rident;
47
with Rtsfind;  use Rtsfind;
48
with Sem;      use Sem;
49
with Sem_Aux;  use Sem_Aux;
50
with Sem_Cat;  use Sem_Cat;
51
with Sem_Ch3;  use Sem_Ch3;
52
with Sem_Ch4;  use Sem_Ch4;
53
with Sem_Ch6;  use Sem_Ch6;
54
with Sem_Ch12; use Sem_Ch12;
55
with Sem_Disp; use Sem_Disp;
56
with Sem_Dist; use Sem_Dist;
57
with Sem_Eval; use Sem_Eval;
58
with Sem_Res;  use Sem_Res;
59
with Sem_Util; use Sem_Util;
60
with Sem_Type; use Sem_Type;
61
with Stand;    use Stand;
62
with Sinfo;    use Sinfo;
63
with Sinfo.CN; use Sinfo.CN;
64
with Snames;   use Snames;
65
with Style;    use Style;
66
with Table;
67
with Tbuild;   use Tbuild;
68
with Uintp;    use Uintp;
69
 
70
package body Sem_Ch8 is
71
 
72
   ------------------------------------
73
   -- Visibility and Name Resolution --
74
   ------------------------------------
75
 
76
   --  This package handles name resolution and the collection of
77
   --  interpretations for overloaded names, prior to overload resolution.
78
 
79
   --  Name resolution is the process that establishes a mapping between source
80
   --  identifiers and the entities they denote at each point in the program.
81
   --  Each entity is represented by a defining occurrence. Each identifier
82
   --  that denotes an entity points to the corresponding defining occurrence.
83
   --  This is the entity of the applied occurrence. Each occurrence holds
84
   --  an index into the names table, where source identifiers are stored.
85
 
86
   --  Each entry in the names table for an identifier or designator uses the
87
   --  Info pointer to hold a link to the currently visible entity that has
88
   --  this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id
89
   --  in package Sem_Util). The visibility is initialized at the beginning of
90
   --  semantic processing to make entities in package Standard immediately
91
   --  visible. The visibility table is used in a more subtle way when
92
   --  compiling subunits (see below).
93
 
94
   --  Entities that have the same name (i.e. homonyms) are chained. In the
95
   --  case of overloaded entities, this chain holds all the possible meanings
96
   --  of a given identifier. The process of overload resolution uses type
97
   --  information to select from this chain the unique meaning of a given
98
   --  identifier.
99
 
100
   --  Entities are also chained in their scope, through the Next_Entity link.
101
   --  As a consequence, the name space is organized as a sparse matrix, where
102
   --  each row corresponds to a scope, and each column to a source identifier.
103
   --  Open scopes, that is to say scopes currently being compiled, have their
104
   --  corresponding rows of entities in order, innermost scope first.
105
 
106
   --  The scopes of packages that are mentioned in  context clauses appear in
107
   --  no particular order, interspersed among open scopes. This is because
108
   --  in the course of analyzing the context of a compilation, a package
109
   --  declaration is first an open scope, and subsequently an element of the
110
   --  context. If subunits or child units are present, a parent unit may
111
   --  appear under various guises at various times in the compilation.
112
 
113
   --  When the compilation of the innermost scope is complete, the entities
114
   --  defined therein are no longer visible. If the scope is not a package
115
   --  declaration, these entities are never visible subsequently, and can be
116
   --  removed from visibility chains. If the scope is a package declaration,
117
   --  its visible declarations may still be accessible. Therefore the entities
118
   --  defined in such a scope are left on the visibility chains, and only
119
   --  their visibility (immediately visibility or potential use-visibility)
120
   --  is affected.
121
 
122
   --  The ordering of homonyms on their chain does not necessarily follow
123
   --  the order of their corresponding scopes on the scope stack. For
124
   --  example, if package P and the enclosing scope both contain entities
125
   --  named E, then when compiling the package body the chain for E will
126
   --  hold the global entity first,  and the local one (corresponding to
127
   --  the current inner scope) next. As a result, name resolution routines
128
   --  do not assume any relative ordering of the homonym chains, either
129
   --  for scope nesting or to order of appearance of context clauses.
130
 
131
   --  When compiling a child unit, entities in the parent scope are always
132
   --  immediately visible. When compiling the body of a child unit, private
133
   --  entities in the parent must also be made immediately visible. There
134
   --  are separate routines to make the visible and private declarations
135
   --  visible at various times (see package Sem_Ch7).
136
 
137
   --              +--------+         +-----+
138
   --              | In use |-------->| EU1 |-------------------------->
139
   --              +--------+         +-----+
140
   --                                    |                      |
141
   --      +--------+                 +-----+                +-----+
142
   --      | Stand. |---------------->| ES1 |--------------->| ES2 |--->
143
   --      +--------+                 +-----+                +-----+
144
   --                                    |                      |
145
   --              +---------+           |                   +-----+
146
   --              | with'ed |------------------------------>| EW2 |--->
147
   --              +---------+           |                   +-----+
148
   --                                    |                      |
149
   --      +--------+                 +-----+                +-----+
150
   --      | Scope2 |---------------->| E12 |--------------->| E22 |--->
151
   --      +--------+                 +-----+                +-----+
152
   --                                    |                      |
153
   --      +--------+                 +-----+                +-----+
154
   --      | Scope1 |---------------->| E11 |--------------->| E12 |--->
155
   --      +--------+                 +-----+                +-----+
156
   --          ^                         |                      |
157
   --          |                         |                      |
158
   --          |   +---------+           |                      |
159
   --          |   | with'ed |----------------------------------------->
160
   --          |   +---------+           |                      |
161
   --          |                         |                      |
162
   --      Scope stack                   |                      |
163
   --      (innermost first)             |                      |
164
   --                                 +----------------------------+
165
   --      Names  table =>            | Id1 |     |    |     | Id2 |
166
   --                                 +----------------------------+
167
 
168
   --  Name resolution must deal with several syntactic forms: simple names,
169
   --  qualified names, indexed names, and various forms of calls.
170
 
171
   --  Each identifier points to an entry in the names table. The resolution
172
   --  of a simple name consists in traversing the homonym chain, starting
173
   --  from the names table. If an entry is immediately visible, it is the one
174
   --  designated by the identifier. If only potentially use-visible entities
175
   --  are on the chain, we must verify that they do not hide each other. If
176
   --  the entity we find is overloadable, we collect all other overloadable
177
   --  entities on the chain as long as they are not hidden.
178
   --
179
   --  To resolve expanded names, we must find the entity at the intersection
180
   --  of the entity chain for the scope (the prefix) and the homonym chain
181
   --  for the selector. In general, homonym chains will be much shorter than
182
   --  entity chains, so it is preferable to start from the names table as
183
   --  well. If the entity found is overloadable, we must collect all other
184
   --  interpretations that are defined in the scope denoted by the prefix.
185
 
186
   --  For records, protected types, and tasks, their local entities are
187
   --  removed from visibility chains on exit from the corresponding scope.
188
   --  From the outside, these entities are always accessed by selected
189
   --  notation, and the entity chain for the record type, protected type,
190
   --  etc. is traversed sequentially in  order to find the designated entity.
191
 
192
   --  The discriminants of a type and the operations of a protected type or
193
   --  task are unchained on  exit from the first view of the type, (such as
194
   --  a private or incomplete type declaration, or a protected type speci-
195
   --  fication) and re-chained when compiling the second view.
196
 
197
   --  In the case of operators,  we do not make operators on derived types
198
   --  explicit. As a result, the notation P."+" may denote either a user-
199
   --  defined function with name "+", or else an implicit declaration of the
200
   --  operator "+" in package P. The resolution of expanded names always
201
   --  tries to resolve an operator name as such an implicitly defined entity,
202
   --  in addition to looking for explicit declarations.
203
 
204
   --  All forms of names that denote entities (simple names, expanded names,
205
   --  character literals in some cases) have a Entity attribute, which
206
   --  identifies the entity denoted by the name.
207
 
208
   ---------------------
209
   -- The Scope Stack --
210
   ---------------------
211
 
212
   --  The Scope stack keeps track of the scopes currently been compiled.
213
   --  Every entity that contains declarations (including records) is placed
214
   --  on the scope stack while it is being processed, and removed at the end.
215
   --  Whenever a non-package scope is exited, the entities defined therein
216
   --  are removed from the visibility table, so that entities in outer scopes
217
   --  become visible (see previous description). On entry to Sem, the scope
218
   --  stack only contains the package Standard. As usual, subunits complicate
219
   --  this picture ever so slightly.
220
 
221
   --  The Rtsfind mechanism can force a call to Semantics while another
222
   --  compilation is in progress. The unit retrieved by Rtsfind must be
223
   --  compiled in  its own context, and has no access to the visibility of
224
   --  the unit currently being compiled. The procedures Save_Scope_Stack and
225
   --  Restore_Scope_Stack make entities in current open scopes invisible
226
   --  before compiling the retrieved unit, and restore the compilation
227
   --  environment afterwards.
228
 
229
   ------------------------
230
   -- Compiling subunits --
231
   ------------------------
232
 
233
   --  Subunits must be compiled in the environment of the corresponding stub,
234
   --  that is to say with the same visibility into the parent (and its
235
   --  context) that is available at the point of the stub declaration, but
236
   --  with the additional visibility provided by the context clause of the
237
   --  subunit itself. As a result, compilation of a subunit forces compilation
238
   --  of the parent (see description in lib-). At the point of the stub
239
   --  declaration, Analyze is called recursively to compile the proper body of
240
   --  the subunit, but without reinitializing the names table, nor the scope
241
   --  stack (i.e. standard is not pushed on the stack). In this fashion the
242
   --  context of the subunit is added to the context of the parent, and the
243
   --  subunit is compiled in the correct environment. Note that in the course
244
   --  of processing the context of a subunit, Standard will appear twice on
245
   --  the scope stack: once for the parent of the subunit, and once for the
246
   --  unit in the context clause being compiled. However, the two sets of
247
   --  entities are not linked by homonym chains, so that the compilation of
248
   --  any context unit happens in a fresh visibility environment.
249
 
250
   -------------------------------
251
   -- Processing of USE Clauses --
252
   -------------------------------
253
 
254
   --  Every defining occurrence has a flag indicating if it is potentially use
255
   --  visible. Resolution of simple names examines this flag. The processing
256
   --  of use clauses consists in setting this flag on all visible entities
257
   --  defined in the corresponding package. On exit from the scope of the use
258
   --  clause, the corresponding flag must be reset. However, a package may
259
   --  appear in several nested use clauses (pathological but legal, alas!)
260
   --  which forces us to use a slightly more involved scheme:
261
 
262
   --    a) The defining occurrence for a package holds a flag -In_Use- to
263
   --    indicate that it is currently in the scope of a use clause. If a
264
   --    redundant use clause is encountered, then the corresponding occurrence
265
   --    of the package name is flagged -Redundant_Use-.
266
 
267
   --    b) On exit from a scope, the use clauses in its declarative part are
268
   --    scanned. The visibility flag is reset in all entities declared in
269
   --    package named in a use clause, as long as the package is not flagged
270
   --    as being in a redundant use clause (in which case the outer use
271
   --    clause is still in effect, and the direct visibility of its entities
272
   --    must be retained).
273
 
274
   --  Note that entities are not removed from their homonym chains on exit
275
   --  from the package specification. A subsequent use clause does not need
276
   --  to rechain the visible entities, but only to establish their direct
277
   --  visibility.
278
 
279
   -----------------------------------
280
   -- Handling private declarations --
281
   -----------------------------------
282
 
283
   --  The principle that each entity has a single defining occurrence clashes
284
   --  with the presence of two separate definitions for private types: the
285
   --  first is the private type declaration, and second is the full type
286
   --  declaration. It is important that all references to the type point to
287
   --  the same defining occurrence, namely the first one. To enforce the two
288
   --  separate views of the entity, the corresponding information is swapped
289
   --  between the two declarations. Outside of the package, the defining
290
   --  occurrence only contains the private declaration information, while in
291
   --  the private part and the body of the package the defining occurrence
292
   --  contains the full declaration. To simplify the swap, the defining
293
   --  occurrence that currently holds the private declaration points to the
294
   --  full declaration. During semantic processing the defining occurrence
295
   --  also points to a list of private dependents, that is to say access types
296
   --  or composite types whose designated types or component types are
297
   --  subtypes or derived types of the private type in question. After the
298
   --  full declaration has been seen, the private dependents are updated to
299
   --  indicate that they have full definitions.
300
 
301
   ------------------------------------
302
   -- Handling of Undefined Messages --
303
   ------------------------------------
304
 
305
   --  In normal mode, only the first use of an undefined identifier generates
306
   --  a message. The table Urefs is used to record error messages that have
307
   --  been issued so that second and subsequent ones do not generate further
308
   --  messages. However, the second reference causes text to be added to the
309
   --  original undefined message noting "(more references follow)". The
310
   --  full error list option (-gnatf) forces messages to be generated for
311
   --  every reference and disconnects the use of this table.
312
 
313
   type Uref_Entry is record
314
      Node : Node_Id;
315
      --  Node for identifier for which original message was posted. The
316
      --  Chars field of this identifier is used to detect later references
317
      --  to the same identifier.
318
 
319
      Err : Error_Msg_Id;
320
      --  Records error message Id of original undefined message. Reset to
321
      --  No_Error_Msg after the second occurrence, where it is used to add
322
      --  text to the original message as described above.
323
 
324
      Nvis : Boolean;
325
      --  Set if the message is not visible rather than undefined
326
 
327
      Loc : Source_Ptr;
328
      --  Records location of error message. Used to make sure that we do
329
      --  not consider a, b : undefined as two separate instances, which
330
      --  would otherwise happen, since the parser converts this sequence
331
      --  to a : undefined; b : undefined.
332
 
333
   end record;
334
 
335
   package Urefs is new Table.Table (
336
     Table_Component_Type => Uref_Entry,
337
     Table_Index_Type     => Nat,
338
     Table_Low_Bound      => 1,
339
     Table_Initial        => 10,
340
     Table_Increment      => 100,
341
     Table_Name           => "Urefs");
342
 
343
   Candidate_Renaming : Entity_Id;
344
   --  Holds a candidate interpretation that appears in a subprogram renaming
345
   --  declaration and does not match the given specification, but matches at
346
   --  least on the first formal. Allows better error message when given
347
   --  specification omits defaulted parameters, a common error.
348
 
349
   -----------------------
350
   -- Local Subprograms --
351
   -----------------------
352
 
353
   procedure Analyze_Generic_Renaming
354
     (N : Node_Id;
355
      K : Entity_Kind);
356
   --  Common processing for all three kinds of generic renaming declarations.
357
   --  Enter new name and indicate that it renames the generic unit.
358
 
359
   procedure Analyze_Renamed_Character
360
     (N       : Node_Id;
361
      New_S   : Entity_Id;
362
      Is_Body : Boolean);
363
   --  Renamed entity is given by a character literal, which must belong
364
   --  to the return type of the new entity. Is_Body indicates whether the
365
   --  declaration is a renaming_as_body. If the original declaration has
366
   --  already been frozen (because of an intervening body, e.g.) the body of
367
   --  the function must be built now. The same applies to the following
368
   --  various renaming procedures.
369
 
370
   procedure Analyze_Renamed_Dereference
371
     (N       : Node_Id;
372
      New_S   : Entity_Id;
373
      Is_Body : Boolean);
374
   --  Renamed entity is given by an explicit dereference. Prefix must be a
375
   --  conformant access_to_subprogram type.
376
 
377
   procedure Analyze_Renamed_Entry
378
     (N       : Node_Id;
379
      New_S   : Entity_Id;
380
      Is_Body : Boolean);
381
   --  If the renamed entity in a subprogram renaming is an entry or protected
382
   --  subprogram, build a body for the new entity whose only statement is a
383
   --  call to the renamed entity.
384
 
385
   procedure Analyze_Renamed_Family_Member
386
     (N       : Node_Id;
387
      New_S   : Entity_Id;
388
      Is_Body : Boolean);
389
   --  Used when the renamed entity is an indexed component. The prefix must
390
   --  denote an entry family.
391
 
392
   procedure Analyze_Renamed_Primitive_Operation
393
     (N       : Node_Id;
394
      New_S   : Entity_Id;
395
      Is_Body : Boolean);
396
   --  If the renamed entity in a subprogram renaming is a primitive operation
397
   --  or a class-wide operation in prefix form, save the target object, which
398
   --  must be added to the list of actuals in any subsequent call.
399
 
400
   function Applicable_Use (Pack_Name : Node_Id) return Boolean;
401
   --  Common code to Use_One_Package and Set_Use, to determine whether
402
   --  use clause must be processed. Pack_Name is an entity name that
403
   --  references the package in question.
404
 
405
   procedure Attribute_Renaming (N : Node_Id);
406
   --  Analyze renaming of attribute as subprogram. The renaming declaration N
407
   --  is rewritten as a subprogram body that returns the attribute reference
408
   --  applied to the formals of the function.
409
 
410
   procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id);
411
   --  A renaming_as_body may occur after the entity of the original decla-
412
   --  ration has been frozen. In that case, the body of the new entity must
413
   --  be built now, because the usual mechanism of building the renamed
414
   --  body at the point of freezing will not work. Subp is the subprogram
415
   --  for which N provides the Renaming_As_Body.
416
 
417
   procedure Check_In_Previous_With_Clause
418
     (N   : Node_Id;
419
      Nam : Node_Id);
420
   --  N is a use_package clause and Nam the package name, or N is a use_type
421
   --  clause and Nam is the prefix of the type name. In either case, verify
422
   --  that the package is visible at that point in the context: either  it
423
   --  appears in a previous with_clause, or because it is a fully qualified
424
   --  name and the root ancestor appears in a previous with_clause.
425
 
426
   procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id);
427
   --  Verify that the entity in a renaming declaration that is a library unit
428
   --  is itself a library unit and not a nested unit or subunit. Also check
429
   --  that if the renaming is a child unit of a generic parent, then the
430
   --  renamed unit must also be a child unit of that parent. Finally, verify
431
   --  that a renamed generic unit is not an implicit child declared within
432
   --  an instance of the parent.
433
 
434
   procedure Chain_Use_Clause (N : Node_Id);
435
   --  Chain use clause onto list of uses clauses headed by First_Use_Clause in
436
   --  the proper scope table entry. This is usually the current scope, but it
437
   --  will be an inner scope when installing the use clauses of the private
438
   --  declarations of a parent unit prior to compiling the private part of a
439
   --  child unit. This chain is traversed when installing/removing use clauses
440
   --  when compiling a subunit or instantiating a generic body on the fly,
441
   --  when it is necessary to save and restore full environments.
442
 
443
   function Has_Implicit_Character_Literal (N : Node_Id) return Boolean;
444
   --  Find a type derived from Character or Wide_Character in the prefix of N.
445
   --  Used to resolved qualified names whose selector is a character literal.
446
 
447
   function Has_Private_With (E : Entity_Id) return Boolean;
448
   --  Ada 2005 (AI-262): Determines if the current compilation unit has a
449
   --  private with on E.
450
 
451
   procedure Find_Expanded_Name (N : Node_Id);
452
   --  Selected component is known to be expanded name. Verify legality of
453
   --  selector given the scope denoted by prefix.
454
 
455
   function Find_Renamed_Entity
456
     (N         : Node_Id;
457
      Nam       : Node_Id;
458
      New_S     : Entity_Id;
459
      Is_Actual : Boolean := False) return Entity_Id;
460
   --  Find the renamed entity that corresponds to the given parameter profile
461
   --  in a subprogram renaming declaration. The renamed entity may be an
462
   --  operator, a subprogram, an entry, or a protected operation. Is_Actual
463
   --  indicates that the renaming is the one generated for an actual subpro-
464
   --  gram in an instance, for which special visibility checks apply.
465
 
466
   function Has_Implicit_Operator (N : Node_Id) return Boolean;
467
   --  N is an expanded name whose selector is an operator name (e.g. P."+").
468
   --  declarative part contains an implicit declaration of an operator if it
469
   --  has a declaration of a type to which one of the predefined operators
470
   --  apply. The existence of this routine is an implementation artifact. A
471
   --  more straightforward but more space-consuming choice would be to make
472
   --  all inherited operators explicit in the symbol table.
473
 
474
   procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id);
475
   --  A subprogram defined by a renaming declaration inherits the parameter
476
   --  profile of the renamed entity. The subtypes given in the subprogram
477
   --  specification are discarded and replaced with those of the renamed
478
   --  subprogram, which are then used to recheck the default values.
479
 
480
   function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
481
   --  Prefix is appropriate for record if it is of a record type, or an access
482
   --  to such.
483
 
484
   function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean;
485
   --  True if it is of a task type, a protected type, or else an access to one
486
   --  of these types.
487
 
488
   procedure Note_Redundant_Use (Clause : Node_Id);
489
   --  Mark the name in a use clause as redundant if the corresponding entity
490
   --  is already use-visible. Emit a warning if the use clause comes from
491
   --  source and the proper warnings are enabled.
492
 
493
   procedure Premature_Usage (N : Node_Id);
494
   --  Diagnose usage of an entity before it is visible
495
 
496
   procedure Use_One_Package (P : Entity_Id; N : Node_Id);
497
   --  Make visible entities declared in package P potentially use-visible
498
   --  in the current context. Also used in the analysis of subunits, when
499
   --  re-installing use clauses of parent units. N is the use_clause that
500
   --  names P (and possibly other packages).
501
 
502
   procedure Use_One_Type (Id : Node_Id);
503
   --  Id is the subtype mark from a use type clause. This procedure makes
504
   --  the primitive operators of the type potentially use-visible.
505
 
506
   procedure Write_Info;
507
   --  Write debugging information on entities declared in current scope
508
 
509
   procedure Write_Scopes;
510
   pragma Warnings (Off, Write_Scopes);
511
   --  Debugging information: dump all entities on scope stack
512
 
513
   --------------------------------
514
   -- Analyze_Exception_Renaming --
515
   --------------------------------
516
 
517
   --  The language only allows a single identifier, but the tree holds an
518
   --  identifier list. The parser has already issued an error message if
519
   --  there is more than one element in the list.
520
 
521
   procedure Analyze_Exception_Renaming (N : Node_Id) is
522
      Id  : constant Node_Id := Defining_Identifier (N);
523
      Nam : constant Node_Id := Name (N);
524
 
525
   begin
526
      Enter_Name (Id);
527
      Analyze (Nam);
528
 
529
      Set_Ekind          (Id, E_Exception);
530
      Set_Exception_Code (Id, Uint_0);
531
      Set_Etype          (Id, Standard_Exception_Type);
532
      Set_Is_Pure        (Id, Is_Pure (Current_Scope));
533
 
534
      if not Is_Entity_Name (Nam) or else
535
        Ekind (Entity (Nam)) /= E_Exception
536
      then
537
         Error_Msg_N ("invalid exception name in renaming", Nam);
538
      else
539
         if Present (Renamed_Object (Entity (Nam))) then
540
            Set_Renamed_Object (Id, Renamed_Object (Entity (Nam)));
541
         else
542
            Set_Renamed_Object (Id, Entity (Nam));
543
         end if;
544
      end if;
545
   end Analyze_Exception_Renaming;
546
 
547
   ---------------------------
548
   -- Analyze_Expanded_Name --
549
   ---------------------------
550
 
551
   procedure Analyze_Expanded_Name (N : Node_Id) is
552
   begin
553
      --  If the entity pointer is already set, this is an internal node, or a
554
      --  node that is analyzed more than once, after a tree modification. In
555
      --  such a case there is no resolution to perform, just set the type. For
556
      --  completeness, analyze prefix as well.
557
 
558
      if Present (Entity (N)) then
559
         if Is_Type (Entity (N)) then
560
            Set_Etype (N, Entity (N));
561
         else
562
            Set_Etype (N, Etype (Entity (N)));
563
         end if;
564
 
565
         Analyze (Prefix (N));
566
         return;
567
      else
568
         Find_Expanded_Name (N);
569
      end if;
570
   end Analyze_Expanded_Name;
571
 
572
   ---------------------------------------
573
   -- Analyze_Generic_Function_Renaming --
574
   ---------------------------------------
575
 
576
   procedure Analyze_Generic_Function_Renaming  (N : Node_Id) is
577
   begin
578
      Analyze_Generic_Renaming (N, E_Generic_Function);
579
   end Analyze_Generic_Function_Renaming;
580
 
581
   --------------------------------------
582
   -- Analyze_Generic_Package_Renaming --
583
   --------------------------------------
584
 
585
   procedure Analyze_Generic_Package_Renaming   (N : Node_Id) is
586
   begin
587
      --  Apply the Text_IO Kludge here, since we may be renaming one of the
588
      --  subpackages of Text_IO, then join common routine.
589
 
590
      Text_IO_Kludge (Name (N));
591
 
592
      Analyze_Generic_Renaming (N, E_Generic_Package);
593
   end Analyze_Generic_Package_Renaming;
594
 
595
   ----------------------------------------
596
   -- Analyze_Generic_Procedure_Renaming --
597
   ----------------------------------------
598
 
599
   procedure Analyze_Generic_Procedure_Renaming (N : Node_Id) is
600
   begin
601
      Analyze_Generic_Renaming (N, E_Generic_Procedure);
602
   end Analyze_Generic_Procedure_Renaming;
603
 
604
   ------------------------------
605
   -- Analyze_Generic_Renaming --
606
   ------------------------------
607
 
608
   procedure Analyze_Generic_Renaming
609
     (N : Node_Id;
610
      K : Entity_Kind)
611
   is
612
      New_P : constant Entity_Id := Defining_Entity (N);
613
      Old_P : Entity_Id;
614
      Inst  : Boolean   := False; -- prevent junk warning
615
 
616
   begin
617
      if Name (N) = Error then
618
         return;
619
      end if;
620
 
621
      Generate_Definition (New_P);
622
 
623
      if Current_Scope /= Standard_Standard then
624
         Set_Is_Pure (New_P, Is_Pure (Current_Scope));
625
      end if;
626
 
627
      if Nkind (Name (N)) = N_Selected_Component then
628
         Check_Generic_Child_Unit (Name (N), Inst);
629
      else
630
         Analyze (Name (N));
631
      end if;
632
 
633
      if not Is_Entity_Name (Name (N)) then
634
         Error_Msg_N ("expect entity name in renaming declaration", Name (N));
635
         Old_P := Any_Id;
636
      else
637
         Old_P := Entity (Name (N));
638
      end if;
639
 
640
      Enter_Name (New_P);
641
      Set_Ekind (New_P, K);
642
 
643
      if Etype (Old_P) = Any_Type then
644
         null;
645
 
646
      elsif Ekind (Old_P) /= K then
647
         Error_Msg_N ("invalid generic unit name", Name (N));
648
 
649
      else
650
         if Present (Renamed_Object (Old_P)) then
651
            Set_Renamed_Object (New_P,  Renamed_Object (Old_P));
652
         else
653
            Set_Renamed_Object (New_P, Old_P);
654
         end if;
655
 
656
         Set_Is_Pure          (New_P, Is_Pure          (Old_P));
657
         Set_Is_Preelaborated (New_P, Is_Preelaborated (Old_P));
658
 
659
         Set_Etype (New_P, Etype (Old_P));
660
         Set_Has_Completion (New_P);
661
 
662
         if In_Open_Scopes (Old_P) then
663
            Error_Msg_N ("within its scope, generic denotes its instance", N);
664
         end if;
665
 
666
         Check_Library_Unit_Renaming (N, Old_P);
667
      end if;
668
   end Analyze_Generic_Renaming;
669
 
670
   -----------------------------
671
   -- Analyze_Object_Renaming --
672
   -----------------------------
673
 
674
   procedure Analyze_Object_Renaming (N : Node_Id) is
675
      Id  : constant Entity_Id := Defining_Identifier (N);
676
      Dec : Node_Id;
677
      Nam : constant Node_Id   := Name (N);
678
      T   : Entity_Id;
679
      T2  : Entity_Id;
680
 
681
      function In_Generic_Scope (E : Entity_Id) return Boolean;
682
      --  Determine whether entity E is inside a generic cope
683
 
684
      ----------------------
685
      -- In_Generic_Scope --
686
      ----------------------
687
 
688
      function In_Generic_Scope (E : Entity_Id) return Boolean is
689
         S : Entity_Id;
690
 
691
      begin
692
         S := Scope (E);
693
         while Present (S) and then S /= Standard_Standard loop
694
            if Is_Generic_Unit (S) then
695
               return True;
696
            end if;
697
 
698
            S := Scope (S);
699
         end loop;
700
 
701
         return False;
702
      end In_Generic_Scope;
703
 
704
   --  Start of processing for Analyze_Object_Renaming
705
 
706
   begin
707
      if Nam = Error then
708
         return;
709
      end if;
710
 
711
      Set_Is_Pure (Id, Is_Pure (Current_Scope));
712
      Enter_Name (Id);
713
 
714
      --  The renaming of a component that depends on a discriminant requires
715
      --  an actual subtype, because in subsequent use of the object Gigi will
716
      --  be unable to locate the actual bounds. This explicit step is required
717
      --  when the renaming is generated in removing side effects of an
718
      --  already-analyzed expression.
719
 
720
      if Nkind (Nam) = N_Selected_Component
721
        and then Analyzed (Nam)
722
      then
723
         T := Etype (Nam);
724
         Dec :=  Build_Actual_Subtype_Of_Component (Etype (Nam), Nam);
725
 
726
         if Present (Dec) then
727
            Insert_Action (N, Dec);
728
            T := Defining_Identifier (Dec);
729
            Set_Etype (Nam, T);
730
         end if;
731
 
732
         --  Complete analysis of the subtype mark in any case, for ASIS use
733
 
734
         if Present (Subtype_Mark (N)) then
735
            Find_Type (Subtype_Mark (N));
736
         end if;
737
 
738
      elsif Present (Subtype_Mark (N)) then
739
         Find_Type (Subtype_Mark (N));
740
         T := Entity (Subtype_Mark (N));
741
         Analyze (Nam);
742
 
743
         if Nkind (Nam) = N_Type_Conversion
744
            and then not Is_Tagged_Type (T)
745
         then
746
            Error_Msg_N
747
              ("renaming of conversion only allowed for tagged types", Nam);
748
         end if;
749
 
750
         Resolve (Nam, T);
751
 
752
         --  Check that a class-wide object is not being renamed as an object
753
         --  of a specific type. The test for access types is needed to exclude
754
         --  cases where the renamed object is a dynamically tagged access
755
         --  result, such as occurs in certain expansions.
756
 
757
         if Is_Tagged_Type (T) then
758
            Check_Dynamically_Tagged_Expression
759
              (Expr        => Nam,
760
               Typ         => T,
761
               Related_Nod => N);
762
         end if;
763
 
764
      --  Ada 2005 (AI-230/AI-254): Access renaming
765
 
766
      else pragma Assert (Present (Access_Definition (N)));
767
         T := Access_Definition
768
                (Related_Nod => N,
769
                 N           => Access_Definition (N));
770
 
771
         Analyze (Nam);
772
 
773
         --  Ada 2005 AI05-105: if the declaration has an anonymous access
774
         --  type, the renamed object must also have an anonymous type, and
775
         --  this is a name resolution rule. This was implicit in the last
776
         --  part of the first sentence in 8.5.1.(3/2), and is made explicit
777
         --  by this recent AI.
778
 
779
         if not Is_Overloaded (Nam) then
780
            if Ekind (Etype (Nam)) /= Ekind (T) then
781
               Error_Msg_N
782
                 ("expect anonymous access type in object renaming", N);
783
            end if;
784
 
785
         else
786
            declare
787
               I    : Interp_Index;
788
               It   : Interp;
789
               Typ  : Entity_Id := Empty;
790
               Seen : Boolean   := False;
791
 
792
            begin
793
               Get_First_Interp (Nam, I, It);
794
               while Present (It.Typ) loop
795
 
796
                  --  Renaming is ambiguous if more than one candidate
797
                  --  interpretation is type-conformant with the context.
798
 
799
                  if Ekind (It.Typ) = Ekind (T) then
800
                     if Ekind (T) = E_Anonymous_Access_Subprogram_Type
801
                       and then
802
                         Type_Conformant
803
                           (Designated_Type (T), Designated_Type (It.Typ))
804
                     then
805
                        if not Seen then
806
                           Seen := True;
807
                        else
808
                           Error_Msg_N
809
                             ("ambiguous expression in renaming", Nam);
810
                        end if;
811
 
812
                     elsif Ekind (T) = E_Anonymous_Access_Type
813
                       and then
814
                         Covers (Designated_Type (T), Designated_Type (It.Typ))
815
                     then
816
                        if not Seen then
817
                           Seen := True;
818
                        else
819
                           Error_Msg_N
820
                             ("ambiguous expression in renaming", Nam);
821
                        end if;
822
                     end if;
823
 
824
                     if Covers (T, It.Typ) then
825
                        Typ := It.Typ;
826
                        Set_Etype (Nam, Typ);
827
                        Set_Is_Overloaded (Nam, False);
828
                     end if;
829
                  end if;
830
 
831
                  Get_Next_Interp (I, It);
832
               end loop;
833
            end;
834
         end if;
835
 
836
         Resolve (Nam, T);
837
 
838
         --  Ada 2005 (AI-231): "In the case where the type is defined by an
839
         --  access_definition, the renamed entity shall be of an access-to-
840
         --  constant type if and only if the access_definition defines an
841
         --  access-to-constant type" ARM 8.5.1(4)
842
 
843
         if Constant_Present (Access_Definition (N))
844
           and then not Is_Access_Constant (Etype (Nam))
845
         then
846
            Error_Msg_N ("(Ada 2005): the renamed object is not "
847
                         & "access-to-constant (RM 8.5.1(6))", N);
848
 
849
         elsif not Constant_Present (Access_Definition (N))
850
           and then Is_Access_Constant (Etype (Nam))
851
         then
852
            Error_Msg_N ("(Ada 2005): the renamed object is not "
853
                         & "access-to-variable (RM 8.5.1(6))", N);
854
         end if;
855
 
856
         if Is_Access_Subprogram_Type (Etype (Nam)) then
857
            Check_Subtype_Conformant
858
              (Designated_Type (T), Designated_Type (Etype (Nam)));
859
 
860
         elsif not Subtypes_Statically_Match
861
                     (Designated_Type (T), Designated_Type (Etype (Nam)))
862
         then
863
            Error_Msg_N
864
              ("subtype of renamed object does not statically match", N);
865
         end if;
866
      end if;
867
 
868
      --  Special processing for renaming function return object. Some errors
869
      --  and warnings are produced only for calls that come from source.
870
 
871
      if Nkind (Nam) = N_Function_Call then
872
         case Ada_Version is
873
 
874
            --  Usage is illegal in Ada 83
875
 
876
            when Ada_83 =>
877
               if Comes_From_Source (Nam) then
878
                  Error_Msg_N
879
                    ("(Ada 83) cannot rename function return object", Nam);
880
               end if;
881
 
882
            --  In Ada 95, warn for odd case of renaming parameterless function
883
            --  call if this is not a limited type (where this is useful).
884
 
885
            when others =>
886
               if Warn_On_Object_Renames_Function
887
                 and then No (Parameter_Associations (Nam))
888
                 and then not Is_Limited_Type (Etype (Nam))
889
                 and then Comes_From_Source (Nam)
890
               then
891
                  Error_Msg_N
892
                    ("?renaming function result object is suspicious", Nam);
893
                  Error_Msg_NE
894
                    ("\?function & will be called only once", Nam,
895
                     Entity (Name (Nam)));
896
                  Error_Msg_N
897
                    ("\?suggest using an initialized constant object instead",
898
                     Nam);
899
               end if;
900
 
901
               --  If the function call returns an unconstrained type, we must
902
               --  build a constrained subtype for the new entity, in a way
903
               --  similar to what is done for an object declaration with an
904
               --  unconstrained nominal type.
905
 
906
               if Is_Composite_Type (Etype (Nam))
907
                 and then not Is_Constrained (Etype (Nam))
908
                 and then not Has_Unknown_Discriminants (Etype (Nam))
909
                 and then Expander_Active
910
               then
911
                  declare
912
                     Loc  : constant Source_Ptr := Sloc (N);
913
                     Subt : constant Entity_Id :=
914
                              Make_Defining_Identifier (Loc,
915
                                Chars => New_Internal_Name ('T'));
916
                  begin
917
                     Remove_Side_Effects (Nam);
918
                     Insert_Action (N,
919
                       Make_Subtype_Declaration (Loc,
920
                         Defining_Identifier => Subt,
921
                         Subtype_Indication  =>
922
                           Make_Subtype_From_Expr (Nam, Etype (Nam))));
923
                     Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc));
924
                     Set_Etype (Nam, Subt);
925
                  end;
926
               end if;
927
         end case;
928
      end if;
929
 
930
      --  An object renaming requires an exact match of the type. Class-wide
931
      --  matching is not allowed.
932
 
933
      if Is_Class_Wide_Type (T)
934
        and then Base_Type (Etype (Nam)) /= Base_Type (T)
935
      then
936
         Wrong_Type (Nam, T);
937
      end if;
938
 
939
      T2 := Etype (Nam);
940
 
941
      --  (Ada 2005: AI-326): Handle wrong use of incomplete type
942
 
943
      if Nkind (Nam) = N_Explicit_Dereference
944
        and then Ekind (Etype (T2)) = E_Incomplete_Type
945
      then
946
         Error_Msg_NE ("invalid use of incomplete type&", Id, T2);
947
         return;
948
 
949
      elsif Ekind (Etype (T)) = E_Incomplete_Type then
950
         Error_Msg_NE ("invalid use of incomplete type&", Id, T);
951
         return;
952
      end if;
953
 
954
      --  Ada 2005 (AI-327)
955
 
956
      if Ada_Version >= Ada_05
957
        and then Nkind (Nam) = N_Attribute_Reference
958
        and then Attribute_Name (Nam) = Name_Priority
959
      then
960
         null;
961
 
962
      elsif Ada_Version >= Ada_05
963
        and then Nkind (Nam) in N_Has_Entity
964
      then
965
         declare
966
            Nam_Decl : Node_Id;
967
            Nam_Ent  : Entity_Id;
968
 
969
         begin
970
            if Nkind (Nam) = N_Attribute_Reference then
971
               Nam_Ent := Entity (Prefix (Nam));
972
            else
973
               Nam_Ent := Entity (Nam);
974
            end if;
975
 
976
            Nam_Decl := Parent (Nam_Ent);
977
 
978
            if Has_Null_Exclusion (N)
979
              and then not Has_Null_Exclusion (Nam_Decl)
980
            then
981
               --  Ada 2005 (AI-423): If the object name denotes a generic
982
               --  formal object of a generic unit G, and the object renaming
983
               --  declaration occurs within the body of G or within the body
984
               --  of a generic unit declared within the declarative region
985
               --  of G, then the declaration of the formal object of G must
986
               --  have a null exclusion or a null-excluding subtype.
987
 
988
               if Is_Formal_Object (Nam_Ent)
989
                    and then In_Generic_Scope (Id)
990
               then
991
                  if not Can_Never_Be_Null (Etype (Nam_Ent)) then
992
                     Error_Msg_N
993
                       ("renamed formal does not exclude `NULL` "
994
                        & "(RM 8.5.1(4.6/2))", N);
995
 
996
                  elsif In_Package_Body (Scope (Id)) then
997
                     Error_Msg_N
998
                       ("formal object does not have a null exclusion"
999
                        & "(RM 8.5.1(4.6/2))", N);
1000
                  end if;
1001
 
1002
               --  Ada 2005 (AI-423): Otherwise, the subtype of the object name
1003
               --  shall exclude null.
1004
 
1005
               elsif not Can_Never_Be_Null (Etype (Nam_Ent)) then
1006
                  Error_Msg_N
1007
                    ("renamed object does not exclude `NULL` "
1008
                     & "(RM 8.5.1(4.6/2))", N);
1009
 
1010
               --  An instance is illegal if it contains a renaming that
1011
               --  excludes null, and the actual does not. The renaming
1012
               --  declaration has already indicated that the declaration
1013
               --  of the renamed actual in the instance will raise
1014
               --  constraint_error.
1015
 
1016
               elsif Nkind (Nam_Decl) = N_Object_Declaration
1017
                 and then In_Instance
1018
                 and then Present
1019
                   (Corresponding_Generic_Association (Nam_Decl))
1020
                 and then Nkind (Expression (Nam_Decl))
1021
                   = N_Raise_Constraint_Error
1022
               then
1023
                  Error_Msg_N
1024
                    ("renamed actual does not exclude `NULL` "
1025
                     & "(RM 8.5.1(4.6/2))", N);
1026
 
1027
               --  Finally, if there is a null exclusion, the subtype mark
1028
               --  must not be null-excluding.
1029
 
1030
               elsif No (Access_Definition (N))
1031
                 and then Can_Never_Be_Null (T)
1032
               then
1033
                  Error_Msg_NE
1034
                    ("`NOT NULL` not allowed (& already excludes null)",
1035
                      N, T);
1036
 
1037
               end if;
1038
 
1039
            elsif Can_Never_Be_Null (T)
1040
              and then not Can_Never_Be_Null (Etype (Nam_Ent))
1041
            then
1042
               Error_Msg_N
1043
                 ("renamed object does not exclude `NULL` "
1044
                  & "(RM 8.5.1(4.6/2))", N);
1045
 
1046
            elsif Has_Null_Exclusion (N)
1047
              and then No (Access_Definition (N))
1048
              and then Can_Never_Be_Null (T)
1049
            then
1050
               Error_Msg_NE
1051
                 ("`NOT NULL` not allowed (& already excludes null)", N, T);
1052
            end if;
1053
         end;
1054
      end if;
1055
 
1056
      Set_Ekind (Id, E_Variable);
1057
      Init_Size_Align (Id);
1058
 
1059
      if T = Any_Type or else Etype (Nam) = Any_Type then
1060
         return;
1061
 
1062
      --  Verify that the renamed entity is an object or a function call. It
1063
      --  may have been rewritten in several ways.
1064
 
1065
      elsif Is_Object_Reference (Nam) then
1066
         if Comes_From_Source (N)
1067
           and then Is_Dependent_Component_Of_Mutable_Object (Nam)
1068
         then
1069
            Error_Msg_N
1070
              ("illegal renaming of discriminant-dependent component", Nam);
1071
         end if;
1072
 
1073
      --  A static function call may have been folded into a literal
1074
 
1075
      elsif Nkind (Original_Node (Nam)) = N_Function_Call
1076
 
1077
            --  When expansion is disabled, attribute reference is not
1078
            --  rewritten as function call. Otherwise it may be rewritten
1079
            --  as a conversion, so check original node.
1080
 
1081
        or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference
1082
                  and then Is_Function_Attribute_Name
1083
                             (Attribute_Name (Original_Node (Nam))))
1084
 
1085
            --  Weird but legal, equivalent to renaming a function call.
1086
            --  Illegal if the literal is the result of constant-folding an
1087
            --  attribute reference that is not a function.
1088
 
1089
        or else (Is_Entity_Name (Nam)
1090
                  and then Ekind (Entity (Nam)) = E_Enumeration_Literal
1091
                  and then
1092
                    Nkind (Original_Node (Nam)) /= N_Attribute_Reference)
1093
 
1094
        or else (Nkind (Nam) = N_Type_Conversion
1095
                    and then Is_Tagged_Type (Entity (Subtype_Mark (Nam))))
1096
      then
1097
         null;
1098
 
1099
      elsif Nkind (Nam) = N_Type_Conversion then
1100
         Error_Msg_N
1101
           ("renaming of conversion only allowed for tagged types", Nam);
1102
 
1103
      --  Ada 2005 (AI-327)
1104
 
1105
      elsif Ada_Version >= Ada_05
1106
        and then Nkind (Nam) = N_Attribute_Reference
1107
        and then Attribute_Name (Nam) = Name_Priority
1108
      then
1109
         null;
1110
 
1111
      --  Allow internally generated x'Reference expression
1112
 
1113
      elsif Nkind (Nam) = N_Reference then
1114
         null;
1115
 
1116
      else
1117
         Error_Msg_N ("expect object name in renaming", Nam);
1118
      end if;
1119
 
1120
      Set_Etype (Id, T2);
1121
 
1122
      if not Is_Variable (Nam) then
1123
         Set_Ekind               (Id, E_Constant);
1124
         Set_Never_Set_In_Source (Id, True);
1125
         Set_Is_True_Constant    (Id, True);
1126
      end if;
1127
 
1128
      Set_Renamed_Object (Id, Nam);
1129
   end Analyze_Object_Renaming;
1130
 
1131
   ------------------------------
1132
   -- Analyze_Package_Renaming --
1133
   ------------------------------
1134
 
1135
   procedure Analyze_Package_Renaming (N : Node_Id) is
1136
      New_P : constant Entity_Id := Defining_Entity (N);
1137
      Old_P : Entity_Id;
1138
      Spec  : Node_Id;
1139
 
1140
   begin
1141
      if Name (N) = Error then
1142
         return;
1143
      end if;
1144
 
1145
      --  Apply Text_IO kludge here since we may be renaming a child of Text_IO
1146
 
1147
      Text_IO_Kludge (Name (N));
1148
 
1149
      if Current_Scope /= Standard_Standard then
1150
         Set_Is_Pure (New_P, Is_Pure (Current_Scope));
1151
      end if;
1152
 
1153
      Enter_Name (New_P);
1154
      Analyze (Name (N));
1155
 
1156
      if Is_Entity_Name (Name (N)) then
1157
         Old_P := Entity (Name (N));
1158
      else
1159
         Old_P := Any_Id;
1160
      end if;
1161
 
1162
      if Etype (Old_P) = Any_Type then
1163
         Error_Msg_N ("expect package name in renaming", Name (N));
1164
 
1165
      elsif Ekind (Old_P) /= E_Package
1166
        and then not (Ekind (Old_P) = E_Generic_Package
1167
                       and then In_Open_Scopes (Old_P))
1168
      then
1169
         if Ekind (Old_P) = E_Generic_Package then
1170
            Error_Msg_N
1171
               ("generic package cannot be renamed as a package", Name (N));
1172
         else
1173
            Error_Msg_Sloc := Sloc (Old_P);
1174
            Error_Msg_NE
1175
             ("expect package name in renaming, found& declared#",
1176
               Name (N), Old_P);
1177
         end if;
1178
 
1179
         --  Set basic attributes to minimize cascaded errors
1180
 
1181
         Set_Ekind (New_P, E_Package);
1182
         Set_Etype (New_P, Standard_Void_Type);
1183
 
1184
      --  Here for OK package renaming
1185
 
1186
      else
1187
         --  Entities in the old package are accessible through the renaming
1188
         --  entity. The simplest implementation is to have both packages share
1189
         --  the entity list.
1190
 
1191
         Set_Ekind (New_P, E_Package);
1192
         Set_Etype (New_P, Standard_Void_Type);
1193
 
1194
         if Present (Renamed_Object (Old_P)) then
1195
            Set_Renamed_Object (New_P,  Renamed_Object (Old_P));
1196
         else
1197
            Set_Renamed_Object (New_P, Old_P);
1198
         end if;
1199
 
1200
         Set_Has_Completion (New_P);
1201
 
1202
         Set_First_Entity (New_P,  First_Entity (Old_P));
1203
         Set_Last_Entity  (New_P,  Last_Entity  (Old_P));
1204
         Set_First_Private_Entity (New_P, First_Private_Entity (Old_P));
1205
         Check_Library_Unit_Renaming (N, Old_P);
1206
         Generate_Reference (Old_P, Name (N));
1207
 
1208
         --  If the renaming is in the visible part of a package, then we set
1209
         --  Renamed_In_Spec for the renamed package, to prevent giving
1210
         --  warnings about no entities referenced. Such a warning would be
1211
         --  overenthusiastic, since clients can see entities in the renamed
1212
         --  package via the visible package renaming.
1213
 
1214
         declare
1215
            Ent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
1216
         begin
1217
            if Ekind (Ent) = E_Package
1218
              and then not In_Private_Part (Ent)
1219
              and then In_Extended_Main_Source_Unit (N)
1220
              and then Ekind (Old_P) = E_Package
1221
            then
1222
               Set_Renamed_In_Spec (Old_P);
1223
            end if;
1224
         end;
1225
 
1226
         --  If this is the renaming declaration of a package instantiation
1227
         --  within itself, it is the declaration that ends the list of actuals
1228
         --  for the instantiation. At this point, the subtypes that rename
1229
         --  the actuals are flagged as generic, to avoid spurious ambiguities
1230
         --  if the actuals for two distinct formals happen to coincide. If
1231
         --  the actual is a private type, the subtype has a private completion
1232
         --  that is flagged in the same fashion.
1233
 
1234
         --  Resolution is identical to what is was in the original generic.
1235
         --  On exit from the generic instance, these are turned into regular
1236
         --  subtypes again, so they are compatible with types in their class.
1237
 
1238
         if not Is_Generic_Instance (Old_P) then
1239
            return;
1240
         else
1241
            Spec := Specification (Unit_Declaration_Node (Old_P));
1242
         end if;
1243
 
1244
         if Nkind (Spec) = N_Package_Specification
1245
           and then Present (Generic_Parent (Spec))
1246
           and then Old_P = Current_Scope
1247
           and then Chars (New_P) = Chars (Generic_Parent (Spec))
1248
         then
1249
            declare
1250
               E : Entity_Id;
1251
 
1252
            begin
1253
               E := First_Entity (Old_P);
1254
               while Present (E)
1255
                 and then E /= New_P
1256
               loop
1257
                  if Is_Type (E)
1258
                    and then Nkind (Parent (E)) = N_Subtype_Declaration
1259
                  then
1260
                     Set_Is_Generic_Actual_Type (E);
1261
 
1262
                     if Is_Private_Type (E)
1263
                       and then Present (Full_View (E))
1264
                     then
1265
                        Set_Is_Generic_Actual_Type (Full_View (E));
1266
                     end if;
1267
                  end if;
1268
 
1269
                  Next_Entity (E);
1270
               end loop;
1271
            end;
1272
         end if;
1273
      end if;
1274
   end Analyze_Package_Renaming;
1275
 
1276
   -------------------------------
1277
   -- Analyze_Renamed_Character --
1278
   -------------------------------
1279
 
1280
   procedure Analyze_Renamed_Character
1281
     (N       : Node_Id;
1282
      New_S   : Entity_Id;
1283
      Is_Body : Boolean)
1284
   is
1285
      C : constant Node_Id := Name (N);
1286
 
1287
   begin
1288
      if Ekind (New_S) = E_Function then
1289
         Resolve (C, Etype (New_S));
1290
 
1291
         if Is_Body then
1292
            Check_Frozen_Renaming (N, New_S);
1293
         end if;
1294
 
1295
      else
1296
         Error_Msg_N ("character literal can only be renamed as function", N);
1297
      end if;
1298
   end Analyze_Renamed_Character;
1299
 
1300
   ---------------------------------
1301
   -- Analyze_Renamed_Dereference --
1302
   ---------------------------------
1303
 
1304
   procedure Analyze_Renamed_Dereference
1305
     (N       : Node_Id;
1306
      New_S   : Entity_Id;
1307
      Is_Body : Boolean)
1308
   is
1309
      Nam : constant Node_Id := Name (N);
1310
      P   : constant Node_Id := Prefix (Nam);
1311
      Typ : Entity_Id;
1312
      Ind : Interp_Index;
1313
      It  : Interp;
1314
 
1315
   begin
1316
      if not Is_Overloaded (P) then
1317
         if Ekind (Etype (Nam)) /= E_Subprogram_Type
1318
           or else not Type_Conformant (Etype (Nam), New_S) then
1319
            Error_Msg_N ("designated type does not match specification", P);
1320
         else
1321
            Resolve (P);
1322
         end if;
1323
 
1324
         return;
1325
 
1326
      else
1327
         Typ := Any_Type;
1328
         Get_First_Interp (Nam, Ind, It);
1329
 
1330
         while Present (It.Nam) loop
1331
 
1332
            if Ekind (It.Nam) = E_Subprogram_Type
1333
              and then Type_Conformant (It.Nam, New_S) then
1334
 
1335
               if Typ /= Any_Id then
1336
                  Error_Msg_N ("ambiguous renaming", P);
1337
                  return;
1338
               else
1339
                  Typ := It.Nam;
1340
               end if;
1341
            end if;
1342
 
1343
            Get_Next_Interp (Ind, It);
1344
         end loop;
1345
 
1346
         if Typ = Any_Type then
1347
            Error_Msg_N ("designated type does not match specification", P);
1348
         else
1349
            Resolve (N, Typ);
1350
 
1351
            if Is_Body then
1352
               Check_Frozen_Renaming (N, New_S);
1353
            end if;
1354
         end if;
1355
      end if;
1356
   end Analyze_Renamed_Dereference;
1357
 
1358
   ---------------------------
1359
   -- Analyze_Renamed_Entry --
1360
   ---------------------------
1361
 
1362
   procedure Analyze_Renamed_Entry
1363
     (N       : Node_Id;
1364
      New_S   : Entity_Id;
1365
      Is_Body : Boolean)
1366
   is
1367
      Nam   : constant Node_Id := Name (N);
1368
      Sel   : constant Node_Id := Selector_Name (Nam);
1369
      Old_S : Entity_Id;
1370
 
1371
   begin
1372
      if Entity (Sel) = Any_Id then
1373
 
1374
         --  Selector is undefined on prefix. Error emitted already
1375
 
1376
         Set_Has_Completion (New_S);
1377
         return;
1378
      end if;
1379
 
1380
      --  Otherwise find renamed entity and build body of New_S as a call to it
1381
 
1382
      Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S);
1383
 
1384
      if Old_S = Any_Id then
1385
         Error_Msg_N (" no subprogram or entry matches specification",  N);
1386
      else
1387
         if Is_Body then
1388
            Check_Subtype_Conformant (New_S, Old_S, N);
1389
            Generate_Reference (New_S, Defining_Entity (N), 'b');
1390
            Style.Check_Identifier (Defining_Entity (N), New_S);
1391
 
1392
         else
1393
            --  Only mode conformance required for a renaming_as_declaration
1394
 
1395
            Check_Mode_Conformant (New_S, Old_S, N);
1396
         end if;
1397
 
1398
         Inherit_Renamed_Profile (New_S, Old_S);
1399
 
1400
         --  The prefix can be an arbitrary expression that yields a task type,
1401
         --  so it must be resolved.
1402
 
1403
         Resolve (Prefix (Nam), Scope (Old_S));
1404
      end if;
1405
 
1406
      Set_Convention (New_S, Convention (Old_S));
1407
      Set_Has_Completion (New_S, Inside_A_Generic);
1408
 
1409
      if Is_Body then
1410
         Check_Frozen_Renaming (N, New_S);
1411
      end if;
1412
   end Analyze_Renamed_Entry;
1413
 
1414
   -----------------------------------
1415
   -- Analyze_Renamed_Family_Member --
1416
   -----------------------------------
1417
 
1418
   procedure Analyze_Renamed_Family_Member
1419
     (N       : Node_Id;
1420
      New_S   : Entity_Id;
1421
      Is_Body : Boolean)
1422
   is
1423
      Nam   : constant Node_Id := Name (N);
1424
      P     : constant Node_Id := Prefix (Nam);
1425
      Old_S : Entity_Id;
1426
 
1427
   begin
1428
      if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family)
1429
        or else (Nkind (P) = N_Selected_Component
1430
                   and then
1431
                 Ekind (Entity (Selector_Name (P))) = E_Entry_Family)
1432
      then
1433
         if Is_Entity_Name (P) then
1434
            Old_S := Entity (P);
1435
         else
1436
            Old_S := Entity (Selector_Name (P));
1437
         end if;
1438
 
1439
         if not Entity_Matches_Spec (Old_S, New_S) then
1440
            Error_Msg_N ("entry family does not match specification", N);
1441
 
1442
         elsif Is_Body then
1443
            Check_Subtype_Conformant (New_S, Old_S, N);
1444
            Generate_Reference (New_S, Defining_Entity (N), 'b');
1445
            Style.Check_Identifier (Defining_Entity (N), New_S);
1446
         end if;
1447
 
1448
      else
1449
         Error_Msg_N ("no entry family matches specification", N);
1450
      end if;
1451
 
1452
      Set_Has_Completion (New_S, Inside_A_Generic);
1453
 
1454
      if Is_Body then
1455
         Check_Frozen_Renaming (N, New_S);
1456
      end if;
1457
   end Analyze_Renamed_Family_Member;
1458
 
1459
   -----------------------------------------
1460
   -- Analyze_Renamed_Primitive_Operation --
1461
   -----------------------------------------
1462
 
1463
   procedure Analyze_Renamed_Primitive_Operation
1464
     (N       : Node_Id;
1465
      New_S   : Entity_Id;
1466
      Is_Body : Boolean)
1467
   is
1468
      Old_S : Entity_Id;
1469
 
1470
      function Conforms
1471
        (Subp : Entity_Id;
1472
         Ctyp : Conformance_Type) return Boolean;
1473
      --  Verify that the signatures of the renamed entity and the new entity
1474
      --  match. The first formal of the renamed entity is skipped because it
1475
      --  is the target object in any subsequent call.
1476
 
1477
      function Conforms
1478
        (Subp : Entity_Id;
1479
         Ctyp : Conformance_Type) return Boolean
1480
      is
1481
         Old_F : Entity_Id;
1482
         New_F : Entity_Id;
1483
 
1484
      begin
1485
         if Ekind (Subp) /= Ekind (New_S) then
1486
            return False;
1487
         end if;
1488
 
1489
         Old_F := Next_Formal (First_Formal (Subp));
1490
         New_F := First_Formal (New_S);
1491
         while Present (Old_F) and then Present (New_F) loop
1492
            if not Conforming_Types (Etype (Old_F), Etype (New_F), Ctyp) then
1493
               return False;
1494
            end if;
1495
 
1496
            if Ctyp >= Mode_Conformant
1497
              and then Ekind (Old_F) /= Ekind (New_F)
1498
            then
1499
               return False;
1500
            end if;
1501
 
1502
            Next_Formal (New_F);
1503
            Next_Formal (Old_F);
1504
         end loop;
1505
 
1506
         return True;
1507
      end Conforms;
1508
 
1509
   begin
1510
      if not Is_Overloaded (Selector_Name (Name (N))) then
1511
         Old_S := Entity (Selector_Name (Name (N)));
1512
 
1513
         if not Conforms (Old_S, Type_Conformant) then
1514
            Old_S := Any_Id;
1515
         end if;
1516
 
1517
      else
1518
         --  Find the operation that matches the given signature
1519
 
1520
         declare
1521
            It  : Interp;
1522
            Ind : Interp_Index;
1523
 
1524
         begin
1525
            Old_S := Any_Id;
1526
            Get_First_Interp (Selector_Name (Name (N)), Ind, It);
1527
 
1528
            while Present (It.Nam) loop
1529
               if Conforms (It.Nam, Type_Conformant) then
1530
                  Old_S := It.Nam;
1531
               end if;
1532
 
1533
               Get_Next_Interp (Ind, It);
1534
            end loop;
1535
         end;
1536
      end if;
1537
 
1538
      if Old_S = Any_Id then
1539
         Error_Msg_N (" no subprogram or entry matches specification",  N);
1540
 
1541
      else
1542
         if Is_Body then
1543
            if not Conforms (Old_S, Subtype_Conformant) then
1544
               Error_Msg_N ("subtype conformance error in renaming", N);
1545
            end if;
1546
 
1547
            Generate_Reference (New_S, Defining_Entity (N), 'b');
1548
            Style.Check_Identifier (Defining_Entity (N), New_S);
1549
 
1550
         else
1551
            --  Only mode conformance required for a renaming_as_declaration
1552
 
1553
            if not Conforms (Old_S, Mode_Conformant) then
1554
               Error_Msg_N ("mode conformance error in renaming", N);
1555
            end if;
1556
         end if;
1557
 
1558
         --  Inherit_Renamed_Profile (New_S, Old_S);
1559
 
1560
         --  The prefix can be an arbitrary expression that yields an
1561
         --  object, so it must be resolved.
1562
 
1563
         Resolve (Prefix (Name (N)));
1564
      end if;
1565
   end Analyze_Renamed_Primitive_Operation;
1566
 
1567
   ---------------------------------
1568
   -- Analyze_Subprogram_Renaming --
1569
   ---------------------------------
1570
 
1571
   procedure Analyze_Subprogram_Renaming (N : Node_Id) is
1572
      Formal_Spec : constant Node_Id          := Corresponding_Formal_Spec (N);
1573
      Is_Actual   : constant Boolean          := Present (Formal_Spec);
1574
      Inst_Node   : Node_Id                   := Empty;
1575
      Nam         : constant Node_Id          := Name (N);
1576
      New_S       : Entity_Id;
1577
      Old_S       : Entity_Id                 := Empty;
1578
      Rename_Spec : Entity_Id;
1579
      Save_AV     : constant Ada_Version_Type := Ada_Version;
1580
      Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit;
1581
      Spec        : constant Node_Id          := Specification (N);
1582
 
1583
      procedure Check_Null_Exclusion
1584
        (Ren : Entity_Id;
1585
         Sub : Entity_Id);
1586
      --  Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the
1587
      --  following AI rules:
1588
      --
1589
      --    If Ren is a renaming of a formal subprogram and one of its
1590
      --    parameters has a null exclusion, then the corresponding formal
1591
      --    in Sub must also have one. Otherwise the subtype of the Sub's
1592
      --    formal parameter must exclude null.
1593
      --
1594
      --    If Ren is a renaming of a formal function and its return
1595
      --    profile has a null exclusion, then Sub's return profile must
1596
      --    have one. Otherwise the subtype of Sub's return profile must
1597
      --    exclude null.
1598
 
1599
      function Original_Subprogram (Subp : Entity_Id) return Entity_Id;
1600
      --  Find renamed entity when the declaration is a renaming_as_body and
1601
      --  the renamed entity may itself be a renaming_as_body. Used to enforce
1602
      --  rule that a renaming_as_body is illegal if the declaration occurs
1603
      --  before the subprogram it completes is frozen, and renaming indirectly
1604
      --  renames the subprogram itself.(Defect Report 8652/0027).
1605
 
1606
      --------------------------
1607
      -- Check_Null_Exclusion --
1608
      --------------------------
1609
 
1610
      procedure Check_Null_Exclusion
1611
        (Ren : Entity_Id;
1612
         Sub : Entity_Id)
1613
      is
1614
         Ren_Formal : Entity_Id;
1615
         Sub_Formal : Entity_Id;
1616
 
1617
      begin
1618
         --  Parameter check
1619
 
1620
         Ren_Formal := First_Formal (Ren);
1621
         Sub_Formal := First_Formal (Sub);
1622
         while Present (Ren_Formal)
1623
           and then Present (Sub_Formal)
1624
         loop
1625
            if Has_Null_Exclusion (Parent (Ren_Formal))
1626
              and then
1627
                not (Has_Null_Exclusion (Parent (Sub_Formal))
1628
                       or else Can_Never_Be_Null (Etype (Sub_Formal)))
1629
            then
1630
               Error_Msg_NE
1631
                 ("`NOT NULL` required for parameter &",
1632
                  Parent (Sub_Formal), Sub_Formal);
1633
            end if;
1634
 
1635
            Next_Formal (Ren_Formal);
1636
            Next_Formal (Sub_Formal);
1637
         end loop;
1638
 
1639
         --  Return profile check
1640
 
1641
         if Nkind (Parent (Ren)) = N_Function_Specification
1642
           and then Nkind (Parent (Sub)) = N_Function_Specification
1643
           and then Has_Null_Exclusion (Parent (Ren))
1644
           and then
1645
             not (Has_Null_Exclusion (Parent (Sub))
1646
                    or else Can_Never_Be_Null (Etype (Sub)))
1647
         then
1648
            Error_Msg_N
1649
              ("return must specify `NOT NULL`",
1650
               Result_Definition (Parent (Sub)));
1651
         end if;
1652
      end Check_Null_Exclusion;
1653
 
1654
      -------------------------
1655
      -- Original_Subprogram --
1656
      -------------------------
1657
 
1658
      function Original_Subprogram (Subp : Entity_Id) return Entity_Id is
1659
         Orig_Decl : Node_Id;
1660
         Orig_Subp : Entity_Id;
1661
 
1662
      begin
1663
         --  First case: renamed entity is itself a renaming
1664
 
1665
         if Present (Alias (Subp)) then
1666
            return Alias (Subp);
1667
 
1668
         elsif
1669
           Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration
1670
             and then Present
1671
              (Corresponding_Body (Unit_Declaration_Node (Subp)))
1672
         then
1673
            --  Check if renamed entity is a renaming_as_body
1674
 
1675
            Orig_Decl :=
1676
              Unit_Declaration_Node
1677
                (Corresponding_Body (Unit_Declaration_Node (Subp)));
1678
 
1679
            if Nkind (Orig_Decl) = N_Subprogram_Renaming_Declaration then
1680
               Orig_Subp := Entity (Name (Orig_Decl));
1681
 
1682
               if Orig_Subp = Rename_Spec then
1683
 
1684
                  --  Circularity detected
1685
 
1686
                  return Orig_Subp;
1687
 
1688
               else
1689
                  return (Original_Subprogram (Orig_Subp));
1690
               end if;
1691
            else
1692
               return Subp;
1693
            end if;
1694
         else
1695
            return Subp;
1696
         end if;
1697
      end Original_Subprogram;
1698
 
1699
   --  Start of processing for Analyze_Subprogram_Renaming
1700
 
1701
   begin
1702
      --  We must test for the attribute renaming case before the Analyze
1703
      --  call because otherwise Sem_Attr will complain that the attribute
1704
      --  is missing an argument when it is analyzed.
1705
 
1706
      if Nkind (Nam) = N_Attribute_Reference then
1707
 
1708
         --  In the case of an abstract formal subprogram association, rewrite
1709
         --  an actual given by a stream attribute as the name of the
1710
         --  corresponding stream primitive of the type.
1711
 
1712
         --  In a generic context the stream operations are not generated, and
1713
         --  this must be treated as a normal attribute reference, to be
1714
         --  expanded in subsequent instantiations.
1715
 
1716
         if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec)
1717
           and then Expander_Active
1718
         then
1719
            declare
1720
               Stream_Prim : Entity_Id;
1721
               Prefix_Type : constant Entity_Id := Entity (Prefix (Nam));
1722
 
1723
            begin
1724
               --  The class-wide forms of the stream attributes are not
1725
               --  primitive dispatching operations (even though they
1726
               --  internally dispatch to a stream attribute).
1727
 
1728
               if Is_Class_Wide_Type (Prefix_Type) then
1729
                  Error_Msg_N
1730
                    ("attribute must be a primitive dispatching operation",
1731
                     Nam);
1732
                  return;
1733
               end if;
1734
 
1735
               --  Retrieve the primitive subprogram associated with the
1736
               --  attribute. This can only be a stream attribute, since those
1737
               --  are the only ones that are dispatching (and the actual for
1738
               --  an abstract formal subprogram must be dispatching
1739
               --  operation).
1740
 
1741
               begin
1742
                  case Attribute_Name (Nam) is
1743
                     when Name_Input  =>
1744
                        Stream_Prim :=
1745
                          Find_Prim_Op (Prefix_Type, TSS_Stream_Input);
1746
                     when Name_Output =>
1747
                        Stream_Prim :=
1748
                          Find_Prim_Op (Prefix_Type, TSS_Stream_Output);
1749
                     when Name_Read   =>
1750
                        Stream_Prim :=
1751
                          Find_Prim_Op (Prefix_Type, TSS_Stream_Read);
1752
                     when Name_Write  =>
1753
                        Stream_Prim :=
1754
                          Find_Prim_Op (Prefix_Type, TSS_Stream_Write);
1755
                     when others      =>
1756
                        Error_Msg_N
1757
                          ("attribute must be a primitive"
1758
                            & " dispatching operation", Nam);
1759
                        return;
1760
                  end case;
1761
 
1762
               exception
1763
 
1764
                  --  If no operation was found, and the type is limited,
1765
                  --  the user should have defined one.
1766
 
1767
                  when Program_Error =>
1768
                     if Is_Limited_Type (Prefix_Type) then
1769
                        Error_Msg_NE
1770
                         ("stream operation not defined for type&",
1771
                           N, Prefix_Type);
1772
                        return;
1773
 
1774
                     --  Otherwise, compiler should have generated default
1775
 
1776
                     else
1777
                        raise;
1778
                     end if;
1779
               end;
1780
 
1781
               --  Rewrite the attribute into the name of its corresponding
1782
               --  primitive dispatching subprogram. We can then proceed with
1783
               --  the usual processing for subprogram renamings.
1784
 
1785
               declare
1786
                  Prim_Name : constant Node_Id :=
1787
                                Make_Identifier (Sloc (Nam),
1788
                                  Chars => Chars (Stream_Prim));
1789
               begin
1790
                  Set_Entity (Prim_Name, Stream_Prim);
1791
                  Rewrite (Nam, Prim_Name);
1792
                  Analyze (Nam);
1793
               end;
1794
            end;
1795
 
1796
         --  Normal processing for a renaming of an attribute
1797
 
1798
         else
1799
            Attribute_Renaming (N);
1800
            return;
1801
         end if;
1802
      end if;
1803
 
1804
      --  Check whether this declaration corresponds to the instantiation
1805
      --  of a formal subprogram.
1806
 
1807
      --  If this is an instantiation, the corresponding actual is frozen and
1808
      --  error messages can be made more precise. If this is a default
1809
      --  subprogram, the entity is already established in the generic, and is
1810
      --  not retrieved by visibility. If it is a default with a box, the
1811
      --  candidate interpretations, if any, have been collected when building
1812
      --  the renaming declaration. If overloaded, the proper interpretation is
1813
      --  determined in Find_Renamed_Entity. If the entity is an operator,
1814
      --  Find_Renamed_Entity applies additional visibility checks.
1815
 
1816
      if Is_Actual then
1817
         Inst_Node := Unit_Declaration_Node (Formal_Spec);
1818
 
1819
         if Is_Entity_Name (Nam)
1820
           and then Present (Entity (Nam))
1821
           and then not Comes_From_Source (Nam)
1822
           and then not Is_Overloaded (Nam)
1823
         then
1824
            Old_S := Entity (Nam);
1825
            New_S := Analyze_Subprogram_Specification (Spec);
1826
 
1827
            --  Operator case
1828
 
1829
            if Ekind (Entity (Nam)) = E_Operator then
1830
 
1831
               --  Box present
1832
 
1833
               if Box_Present (Inst_Node) then
1834
                  Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
1835
 
1836
               --  If there is an immediately visible homonym of the operator
1837
               --  and the declaration has a default, this is worth a warning
1838
               --  because the user probably did not intend to get the pre-
1839
               --  defined operator, visible in the generic declaration. To
1840
               --  find if there is an intended candidate, analyze the renaming
1841
               --  again in the current context.
1842
 
1843
               elsif Scope (Old_S) = Standard_Standard
1844
                 and then Present (Default_Name (Inst_Node))
1845
               then
1846
                  declare
1847
                     Decl   : constant Node_Id := New_Copy_Tree (N);
1848
                     Hidden : Entity_Id;
1849
 
1850
                  begin
1851
                     Set_Entity (Name (Decl), Empty);
1852
                     Analyze (Name (Decl));
1853
                     Hidden :=
1854
                       Find_Renamed_Entity (Decl, Name (Decl), New_S, True);
1855
 
1856
                     if Present (Hidden)
1857
                       and then In_Open_Scopes (Scope (Hidden))
1858
                       and then Is_Immediately_Visible (Hidden)
1859
                       and then Comes_From_Source (Hidden)
1860
                       and then Hidden /= Old_S
1861
                     then
1862
                        Error_Msg_Sloc := Sloc (Hidden);
1863
                        Error_Msg_N ("?default subprogram is resolved " &
1864
                                     "in the generic declaration " &
1865
                                     "(RM 12.6(17))", N);
1866
                        Error_Msg_NE ("\?and will not use & #", N, Hidden);
1867
                     end if;
1868
                  end;
1869
               end if;
1870
            end if;
1871
 
1872
         else
1873
            Analyze (Nam);
1874
            New_S := Analyze_Subprogram_Specification (Spec);
1875
         end if;
1876
 
1877
      else
1878
         --  Renamed entity must be analyzed first, to avoid being hidden by
1879
         --  new name (which might be the same in a generic instance).
1880
 
1881
         Analyze (Nam);
1882
 
1883
         --  The renaming defines a new overloaded entity, which is analyzed
1884
         --  like a subprogram declaration.
1885
 
1886
         New_S := Analyze_Subprogram_Specification (Spec);
1887
      end if;
1888
 
1889
      if Current_Scope /= Standard_Standard then
1890
         Set_Is_Pure (New_S, Is_Pure (Current_Scope));
1891
      end if;
1892
 
1893
      Rename_Spec := Find_Corresponding_Spec (N);
1894
 
1895
      --  Case of Renaming_As_Body
1896
 
1897
      if Present (Rename_Spec) then
1898
 
1899
         --  Renaming declaration is the completion of the declaration of
1900
         --  Rename_Spec. We build an actual body for it at the freezing point.
1901
 
1902
         Set_Corresponding_Spec (N, Rename_Spec);
1903
 
1904
         --  Deal with special case of stream functions of abstract types
1905
         --  and interfaces.
1906
 
1907
         if Nkind (Unit_Declaration_Node (Rename_Spec)) =
1908
                                     N_Abstract_Subprogram_Declaration
1909
         then
1910
            --  Input stream functions are abstract if the object type is
1911
            --  abstract. Similarly, all default stream functions for an
1912
            --  interface type are abstract. However, these subprograms may
1913
            --  receive explicit declarations in representation clauses, making
1914
            --  the attribute subprograms usable as defaults in subsequent
1915
            --  type extensions.
1916
            --  In this case we rewrite the declaration to make the subprogram
1917
            --  non-abstract. We remove the previous declaration, and insert
1918
            --  the new one at the point of the renaming, to prevent premature
1919
            --  access to unfrozen types. The new declaration reuses the
1920
            --  specification of the previous one, and must not be analyzed.
1921
 
1922
            pragma Assert
1923
              (Is_Primitive (Entity (Nam))
1924
                 and then
1925
                   Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam))));
1926
            declare
1927
               Old_Decl : constant Node_Id :=
1928
                            Unit_Declaration_Node (Rename_Spec);
1929
               New_Decl : constant Node_Id :=
1930
                            Make_Subprogram_Declaration (Sloc (N),
1931
                              Specification =>
1932
                                Relocate_Node (Specification (Old_Decl)));
1933
            begin
1934
               Remove (Old_Decl);
1935
               Insert_After (N, New_Decl);
1936
               Set_Is_Abstract_Subprogram (Rename_Spec, False);
1937
               Set_Analyzed (New_Decl);
1938
            end;
1939
         end if;
1940
 
1941
         Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S);
1942
 
1943
         if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1944
            Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N);
1945
         end if;
1946
 
1947
         Set_Convention (New_S, Convention (Rename_Spec));
1948
         Check_Fully_Conformant (New_S, Rename_Spec);
1949
         Set_Public_Status (New_S);
1950
 
1951
         --  The specification does not introduce new formals, but only
1952
         --  repeats the formals of the original subprogram declaration.
1953
         --  For cross-reference purposes, and for refactoring tools, we
1954
         --  treat the formals of the renaming declaration as body formals.
1955
 
1956
         Reference_Body_Formals (Rename_Spec, New_S);
1957
 
1958
         --  Indicate that the entity in the declaration functions like the
1959
         --  corresponding body, and is not a new entity. The body will be
1960
         --  constructed later at the freeze point, so indicate that the
1961
         --  completion has not been seen yet.
1962
 
1963
         Set_Ekind (New_S, E_Subprogram_Body);
1964
         New_S := Rename_Spec;
1965
         Set_Has_Completion (Rename_Spec, False);
1966
 
1967
         --  Ada 2005: check overriding indicator
1968
 
1969
         if Is_Overriding_Operation (Rename_Spec) then
1970
            if Must_Not_Override (Specification (N)) then
1971
               Error_Msg_NE
1972
                 ("subprogram& overrides inherited operation",
1973
                    N, Rename_Spec);
1974
            elsif
1975
              Style_Check and then not Must_Override (Specification (N))
1976
            then
1977
               Style.Missing_Overriding (N, Rename_Spec);
1978
            end if;
1979
 
1980
         elsif Must_Override (Specification (N)) then
1981
            Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec);
1982
         end if;
1983
 
1984
      --  Normal subprogram renaming (not renaming as body)
1985
 
1986
      else
1987
         Generate_Definition (New_S);
1988
         New_Overloaded_Entity (New_S);
1989
 
1990
         if Is_Entity_Name (Nam)
1991
           and then Is_Intrinsic_Subprogram (Entity (Nam))
1992
         then
1993
            null;
1994
         else
1995
            Check_Delayed_Subprogram (New_S);
1996
         end if;
1997
      end if;
1998
 
1999
      --  There is no need for elaboration checks on the new entity, which may
2000
      --  be called before the next freezing point where the body will appear.
2001
      --  Elaboration checks refer to the real entity, not the one created by
2002
      --  the renaming declaration.
2003
 
2004
      Set_Kill_Elaboration_Checks (New_S, True);
2005
 
2006
      if Etype (Nam) = Any_Type then
2007
         Set_Has_Completion (New_S);
2008
         return;
2009
 
2010
      elsif Nkind (Nam) = N_Selected_Component then
2011
 
2012
         --  A prefix of the form  A.B can designate an entry of task A, a
2013
         --  protected operation of protected object A, or finally a primitive
2014
         --  operation of object A. In the later case, A is an object of some
2015
         --  tagged type, or an access type that denotes one such. To further
2016
         --  distinguish these cases, note that the scope of a task entry or
2017
         --  protected operation is type of the prefix.
2018
 
2019
         --  The prefix could be an overloaded function call that returns both
2020
         --  kinds of operations. This overloading pathology is left to the
2021
         --  dedicated reader ???
2022
 
2023
         declare
2024
            T : constant Entity_Id := Etype (Prefix (Nam));
2025
 
2026
         begin
2027
            if Present (T)
2028
              and then
2029
                (Is_Tagged_Type (T)
2030
                  or else
2031
                    (Is_Access_Type (T)
2032
                      and then
2033
                        Is_Tagged_Type (Designated_Type (T))))
2034
              and then Scope (Entity (Selector_Name (Nam))) /= T
2035
            then
2036
               Analyze_Renamed_Primitive_Operation
2037
                 (N, New_S, Present (Rename_Spec));
2038
               return;
2039
 
2040
            else
2041
               --  Renamed entity is an entry or protected operation. For those
2042
               --  cases an explicit body is built (at the point of freezing of
2043
               --  this entity) that contains a call to the renamed entity.
2044
 
2045
               --  This is not allowed for renaming as body if the renamed
2046
               --  spec is already frozen (see RM 8.5.4(5) for details).
2047
 
2048
               if Present (Rename_Spec)
2049
                 and then Is_Frozen (Rename_Spec)
2050
               then
2051
                  Error_Msg_N
2052
                    ("renaming-as-body cannot rename entry as subprogram", N);
2053
                  Error_Msg_NE
2054
                    ("\since & is already frozen (RM 8.5.4(5))",
2055
                     N, Rename_Spec);
2056
               else
2057
                  Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec));
2058
               end if;
2059
 
2060
               return;
2061
            end if;
2062
         end;
2063
 
2064
      elsif Nkind (Nam) = N_Explicit_Dereference then
2065
 
2066
         --  Renamed entity is designated by access_to_subprogram expression.
2067
         --  Must build body to encapsulate call, as in the entry case.
2068
 
2069
         Analyze_Renamed_Dereference (N, New_S, Present (Rename_Spec));
2070
         return;
2071
 
2072
      elsif Nkind (Nam) = N_Indexed_Component then
2073
         Analyze_Renamed_Family_Member (N, New_S, Present (Rename_Spec));
2074
         return;
2075
 
2076
      elsif Nkind (Nam) = N_Character_Literal then
2077
         Analyze_Renamed_Character (N, New_S, Present (Rename_Spec));
2078
         return;
2079
 
2080
      elsif (not Is_Entity_Name (Nam)
2081
              and then Nkind (Nam) /= N_Operator_Symbol)
2082
        or else not Is_Overloadable (Entity (Nam))
2083
      then
2084
         Error_Msg_N ("expect valid subprogram name in renaming", N);
2085
         return;
2086
      end if;
2087
 
2088
      --  Find the renamed entity that matches the given specification. Disable
2089
      --  Ada_83 because there is no requirement of full conformance between
2090
      --  renamed entity and new entity, even though the same circuit is used.
2091
 
2092
      --  This is a bit of a kludge, which introduces a really irregular use of
2093
      --  Ada_Version[_Explicit]. Would be nice to find cleaner way to do this
2094
      --  ???
2095
 
2096
      Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95);
2097
      Ada_Version_Explicit := Ada_Version;
2098
 
2099
      if No (Old_S) then
2100
         Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
2101
 
2102
         --  When the renamed subprogram is overloaded and used as an actual
2103
         --  of a generic, its entity is set to the first available homonym.
2104
         --  We must first disambiguate the name, then set the proper entity.
2105
 
2106
         if Is_Actual
2107
           and then Is_Overloaded (Nam)
2108
         then
2109
            Set_Entity (Nam, Old_S);
2110
         end if;
2111
      end if;
2112
 
2113
      --  Most common case: subprogram renames subprogram. No body is generated
2114
      --  in this case, so we must indicate the declaration is complete as is.
2115
      --  and inherit various attributes of the renamed subprogram.
2116
 
2117
      if No (Rename_Spec) then
2118
         Set_Has_Completion   (New_S);
2119
         Set_Is_Imported      (New_S, Is_Imported      (Entity (Nam)));
2120
         Set_Is_Pure          (New_S, Is_Pure          (Entity (Nam)));
2121
         Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam)));
2122
 
2123
         --  Ada 2005 (AI-423): Check the consistency of null exclusions
2124
         --  between a subprogram and its correct renaming.
2125
 
2126
         --  Note: the Any_Id check is a guard that prevents compiler crashes
2127
         --  when performing a null exclusion check between a renaming and a
2128
         --  renamed subprogram that has been found to be illegal.
2129
 
2130
         if Ada_Version >= Ada_05
2131
           and then Entity (Nam) /= Any_Id
2132
         then
2133
            Check_Null_Exclusion
2134
              (Ren => New_S,
2135
               Sub => Entity (Nam));
2136
         end if;
2137
 
2138
         --  Enforce the Ada 2005 rule that the renamed entity cannot require
2139
         --  overriding. The flag Requires_Overriding is set very selectively
2140
         --  and misses some other illegal cases. The additional conditions
2141
         --  checked below are sufficient but not necessary ???
2142
 
2143
         --  The rule does not apply to the renaming generated for an actual
2144
         --  subprogram in an instance.
2145
 
2146
         if Is_Actual then
2147
            null;
2148
 
2149
         --  Guard against previous errors, and omit renamings of predefined
2150
         --  operators.
2151
 
2152
         elsif Ekind (Old_S) /= E_Function
2153
           and then Ekind (Old_S) /= E_Procedure
2154
         then
2155
            null;
2156
 
2157
         elsif Requires_Overriding (Old_S)
2158
           or else
2159
              (Is_Abstract_Subprogram (Old_S)
2160
                 and then Present (Find_Dispatching_Type (Old_S))
2161
                 and then
2162
                   not Is_Abstract_Type (Find_Dispatching_Type (Old_S)))
2163
         then
2164
            Error_Msg_N
2165
              ("renamed entity cannot be "
2166
               & "subprogram that requires overriding (RM 8.5.4 (5.1))", N);
2167
         end if;
2168
      end if;
2169
 
2170
      if Old_S /= Any_Id then
2171
         if Is_Actual
2172
           and then From_Default (N)
2173
         then
2174
            --  This is an implicit reference to the default actual
2175
 
2176
            Generate_Reference (Old_S, Nam, Typ => 'i', Force => True);
2177
         else
2178
            Generate_Reference (Old_S, Nam);
2179
         end if;
2180
 
2181
         --  For a renaming-as-body, require subtype conformance, but if the
2182
         --  declaration being completed has not been frozen, then inherit the
2183
         --  convention of the renamed subprogram prior to checking conformance
2184
         --  (unless the renaming has an explicit convention established; the
2185
         --  rule stated in the RM doesn't seem to address this ???).
2186
 
2187
         if Present (Rename_Spec) then
2188
            Generate_Reference (Rename_Spec, Defining_Entity (Spec), 'b');
2189
            Style.Check_Identifier (Defining_Entity (Spec), Rename_Spec);
2190
 
2191
            if not Is_Frozen (Rename_Spec) then
2192
               if not Has_Convention_Pragma (Rename_Spec) then
2193
                  Set_Convention (New_S, Convention (Old_S));
2194
               end if;
2195
 
2196
               if Ekind (Old_S) /= E_Operator then
2197
                  Check_Mode_Conformant (New_S, Old_S, Spec);
2198
               end if;
2199
 
2200
               if Original_Subprogram (Old_S) = Rename_Spec then
2201
                  Error_Msg_N ("unfrozen subprogram cannot rename itself ", N);
2202
               end if;
2203
            else
2204
               Check_Subtype_Conformant (New_S, Old_S, Spec);
2205
            end if;
2206
 
2207
            Check_Frozen_Renaming (N, Rename_Spec);
2208
 
2209
            --  Check explicitly that renamed entity is not intrinsic, because
2210
            --  in a generic the renamed body is not built. In this case,
2211
            --  the renaming_as_body is a completion.
2212
 
2213
            if Inside_A_Generic then
2214
               if Is_Frozen (Rename_Spec)
2215
                 and then Is_Intrinsic_Subprogram (Old_S)
2216
               then
2217
                  Error_Msg_N
2218
                    ("subprogram in renaming_as_body cannot be intrinsic",
2219
                       Name (N));
2220
               end if;
2221
 
2222
               Set_Has_Completion (Rename_Spec);
2223
            end if;
2224
 
2225
         elsif Ekind (Old_S) /= E_Operator then
2226
            Check_Mode_Conformant (New_S, Old_S);
2227
 
2228
            if Is_Actual
2229
              and then Error_Posted (New_S)
2230
            then
2231
               Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S);
2232
            end if;
2233
         end if;
2234
 
2235
         if No (Rename_Spec) then
2236
 
2237
            --  The parameter profile of the new entity is that of the renamed
2238
            --  entity: the subtypes given in the specification are irrelevant.
2239
 
2240
            Inherit_Renamed_Profile (New_S, Old_S);
2241
 
2242
            --  A call to the subprogram is transformed into a call to the
2243
            --  renamed entity. This is transitive if the renamed entity is
2244
            --  itself a renaming.
2245
 
2246
            if Present (Alias (Old_S)) then
2247
               Set_Alias (New_S, Alias (Old_S));
2248
            else
2249
               Set_Alias (New_S, Old_S);
2250
            end if;
2251
 
2252
            --  Note that we do not set Is_Intrinsic_Subprogram if we have a
2253
            --  renaming as body, since the entity in this case is not an
2254
            --  intrinsic (it calls an intrinsic, but we have a real body for
2255
            --  this call, and it is in this body that the required intrinsic
2256
            --  processing will take place).
2257
 
2258
            --  Also, if this is a renaming of inequality, the renamed operator
2259
            --  is intrinsic, but what matters is the corresponding equality
2260
            --  operator, which may be user-defined.
2261
 
2262
            Set_Is_Intrinsic_Subprogram
2263
              (New_S,
2264
                Is_Intrinsic_Subprogram (Old_S)
2265
                  and then
2266
                    (Chars (Old_S) /= Name_Op_Ne
2267
                       or else Ekind (Old_S) = E_Operator
2268
                       or else
2269
                         Is_Intrinsic_Subprogram
2270
                            (Corresponding_Equality (Old_S))));
2271
 
2272
            if Ekind (Alias (New_S)) = E_Operator then
2273
               Set_Has_Delayed_Freeze (New_S, False);
2274
            end if;
2275
 
2276
            --  If the renaming corresponds to an association for an abstract
2277
            --  formal subprogram, then various attributes must be set to
2278
            --  indicate that the renaming is an abstract dispatching operation
2279
            --  with a controlling type.
2280
 
2281
            if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) then
2282
 
2283
               --  Mark the renaming as abstract here, so Find_Dispatching_Type
2284
               --  see it as corresponding to a generic association for a
2285
               --  formal abstract subprogram
2286
 
2287
               Set_Is_Abstract_Subprogram (New_S);
2288
 
2289
               declare
2290
                  New_S_Ctrl_Type : constant Entity_Id :=
2291
                                      Find_Dispatching_Type (New_S);
2292
                  Old_S_Ctrl_Type : constant Entity_Id :=
2293
                                      Find_Dispatching_Type (Old_S);
2294
 
2295
               begin
2296
                  if Old_S_Ctrl_Type /= New_S_Ctrl_Type then
2297
                     Error_Msg_NE
2298
                       ("actual must be dispatching subprogram for type&",
2299
                        Nam, New_S_Ctrl_Type);
2300
 
2301
                  else
2302
                     Set_Is_Dispatching_Operation (New_S);
2303
                     Check_Controlling_Formals (New_S_Ctrl_Type, New_S);
2304
 
2305
                     --  If the actual in the formal subprogram is itself a
2306
                     --  formal abstract subprogram association, there's no
2307
                     --  dispatch table component or position to inherit.
2308
 
2309
                     if Present (DTC_Entity (Old_S)) then
2310
                        Set_DTC_Entity  (New_S, DTC_Entity (Old_S));
2311
                        Set_DT_Position (New_S, DT_Position (Old_S));
2312
                     end if;
2313
                  end if;
2314
               end;
2315
            end if;
2316
         end if;
2317
 
2318
         if not Is_Actual
2319
           and then (Old_S = New_S
2320
                      or else (Nkind (Nam) /= N_Expanded_Name
2321
                        and then  Chars (Old_S) = Chars (New_S)))
2322
         then
2323
            Error_Msg_N ("subprogram cannot rename itself", N);
2324
         end if;
2325
 
2326
         Set_Convention (New_S, Convention (Old_S));
2327
 
2328
         if Is_Abstract_Subprogram (Old_S) then
2329
            if Present (Rename_Spec) then
2330
               Error_Msg_N
2331
                 ("a renaming-as-body cannot rename an abstract subprogram",
2332
                  N);
2333
               Set_Has_Completion (Rename_Spec);
2334
            else
2335
               Set_Is_Abstract_Subprogram (New_S);
2336
            end if;
2337
         end if;
2338
 
2339
         Check_Library_Unit_Renaming (N, Old_S);
2340
 
2341
         --  Pathological case: procedure renames entry in the scope of its
2342
         --  task. Entry is given by simple name, but body must be built for
2343
         --  procedure. Of course if called it will deadlock.
2344
 
2345
         if Ekind (Old_S) = E_Entry then
2346
            Set_Has_Completion (New_S, False);
2347
            Set_Alias (New_S, Empty);
2348
         end if;
2349
 
2350
         if Is_Actual then
2351
            Freeze_Before (N, Old_S);
2352
            Set_Has_Delayed_Freeze (New_S, False);
2353
            Freeze_Before (N, New_S);
2354
 
2355
            --  An abstract subprogram is only allowed as an actual in the case
2356
            --  where the formal subprogram is also abstract.
2357
 
2358
            if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function)
2359
              and then Is_Abstract_Subprogram (Old_S)
2360
              and then not Is_Abstract_Subprogram (Formal_Spec)
2361
            then
2362
               Error_Msg_N
2363
                 ("abstract subprogram not allowed as generic actual", Nam);
2364
            end if;
2365
         end if;
2366
 
2367
      else
2368
         --  A common error is to assume that implicit operators for types are
2369
         --  defined in Standard, or in the scope of a subtype. In those cases
2370
         --  where the renamed entity is given with an expanded name, it is
2371
         --  worth mentioning that operators for the type are not declared in
2372
         --  the scope given by the prefix.
2373
 
2374
         if Nkind (Nam) = N_Expanded_Name
2375
           and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol
2376
           and then Scope (Entity (Nam)) = Standard_Standard
2377
         then
2378
            declare
2379
               T : constant Entity_Id :=
2380
                     Base_Type (Etype (First_Formal (New_S)));
2381
            begin
2382
               Error_Msg_Node_2 := Prefix (Nam);
2383
               Error_Msg_NE
2384
                 ("operator for type& is not declared in&", Prefix (Nam), T);
2385
            end;
2386
 
2387
         else
2388
            Error_Msg_NE
2389
              ("no visible subprogram matches the specification for&",
2390
                Spec, New_S);
2391
         end if;
2392
 
2393
         if Present (Candidate_Renaming) then
2394
            declare
2395
               F1 : Entity_Id;
2396
               F2 : Entity_Id;
2397
               T1 : Entity_Id;
2398
 
2399
            begin
2400
               F1 := First_Formal (Candidate_Renaming);
2401
               F2 := First_Formal (New_S);
2402
               T1 := First_Subtype (Etype (F1));
2403
 
2404
               while Present (F1) and then Present (F2) loop
2405
                  Next_Formal (F1);
2406
                  Next_Formal (F2);
2407
               end loop;
2408
 
2409
               if Present (F1) and then Present (Default_Value (F1)) then
2410
                  if Present (Next_Formal (F1)) then
2411
                     Error_Msg_NE
2412
                       ("\missing specification for &" &
2413
                          " and other formals with defaults", Spec, F1);
2414
                  else
2415
                     Error_Msg_NE
2416
                    ("\missing specification for &", Spec, F1);
2417
                  end if;
2418
               end if;
2419
 
2420
               if Nkind (Nam) = N_Operator_Symbol
2421
                 and then From_Default (N)
2422
               then
2423
                  Error_Msg_Node_2 := T1;
2424
                  Error_Msg_NE
2425
                    ("default & on & is not directly visible",
2426
                      Nam, Nam);
2427
               end if;
2428
            end;
2429
         end if;
2430
      end if;
2431
 
2432
      --  Ada 2005 AI 404: if the new subprogram is dispatching, verify that
2433
      --  controlling access parameters are known non-null for the renamed
2434
      --  subprogram. Test also applies to a subprogram instantiation that
2435
      --  is dispatching. Test is skipped if some previous error was detected
2436
      --  that set Old_S to Any_Id.
2437
 
2438
      if Ada_Version >= Ada_05
2439
        and then Old_S /= Any_Id
2440
        and then not Is_Dispatching_Operation (Old_S)
2441
        and then Is_Dispatching_Operation (New_S)
2442
      then
2443
         declare
2444
            Old_F : Entity_Id;
2445
            New_F : Entity_Id;
2446
 
2447
         begin
2448
            Old_F := First_Formal (Old_S);
2449
            New_F := First_Formal (New_S);
2450
            while Present (Old_F) loop
2451
               if Ekind (Etype (Old_F)) = E_Anonymous_Access_Type
2452
                 and then Is_Controlling_Formal (New_F)
2453
                 and then not Can_Never_Be_Null (Old_F)
2454
               then
2455
                  Error_Msg_N ("access parameter is controlling,", New_F);
2456
                  Error_Msg_NE
2457
                    ("\corresponding parameter of& "
2458
                     & "must be explicitly null excluding", New_F, Old_S);
2459
               end if;
2460
 
2461
               Next_Formal (Old_F);
2462
               Next_Formal (New_F);
2463
            end loop;
2464
         end;
2465
      end if;
2466
 
2467
      --  A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005)
2468
 
2469
      if Comes_From_Source (N)
2470
        and then Present (Old_S)
2471
        and then Nkind (Old_S) = N_Defining_Operator_Symbol
2472
        and then Nkind (New_S) = N_Defining_Operator_Symbol
2473
        and then Chars (Old_S) /= Chars (New_S)
2474
      then
2475
         Error_Msg_NE
2476
           ("?& is being renamed as a different operator",
2477
             New_S, Old_S);
2478
      end if;
2479
 
2480
      --  Another warning or some utility: if the new subprogram as the same
2481
      --  name as the old one, the old one is not hidden by an outer homograph,
2482
      --  the new one is not a public symbol, and the old one is otherwise
2483
      --  directly visible, the renaming is superfluous.
2484
 
2485
      if Chars (Old_S) = Chars (New_S)
2486
        and then Comes_From_Source (N)
2487
        and then Scope (Old_S) /= Standard_Standard
2488
        and then Warn_On_Redundant_Constructs
2489
        and then
2490
          (Is_Immediately_Visible (Old_S)
2491
            or else Is_Potentially_Use_Visible (Old_S))
2492
        and then Is_Overloadable (Current_Scope)
2493
        and then Chars (Current_Scope) /= Chars (Old_S)
2494
      then
2495
         Error_Msg_N
2496
          ("?redundant renaming, entity is directly visible", Name (N));
2497
      end if;
2498
 
2499
      Ada_Version := Save_AV;
2500
      Ada_Version_Explicit := Save_AV_Exp;
2501
   end Analyze_Subprogram_Renaming;
2502
 
2503
   -------------------------
2504
   -- Analyze_Use_Package --
2505
   -------------------------
2506
 
2507
   --  Resolve the package names in the use clause, and make all the visible
2508
   --  entities defined in the package potentially use-visible. If the package
2509
   --  is already in use from a previous use clause, its visible entities are
2510
   --  already use-visible. In that case, mark the occurrence as a redundant
2511
   --  use. If the package is an open scope, i.e. if the use clause occurs
2512
   --  within the package itself, ignore it.
2513
 
2514
   procedure Analyze_Use_Package (N : Node_Id) is
2515
      Pack_Name : Node_Id;
2516
      Pack      : Entity_Id;
2517
 
2518
   --  Start of processing for Analyze_Use_Package
2519
 
2520
   begin
2521
      Set_Hidden_By_Use_Clause (N, No_Elist);
2522
 
2523
      --  Use clause is not allowed in a spec of a predefined package
2524
      --  declaration except that packages whose file name starts a-n are OK
2525
      --  (these are children of Ada.Numerics, and such packages are never
2526
      --  loaded by Rtsfind).
2527
 
2528
      if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
2529
        and then Name_Buffer (1 .. 3) /= "a-n"
2530
        and then
2531
          Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
2532
      then
2533
         Error_Msg_N ("use clause not allowed in predefined spec", N);
2534
      end if;
2535
 
2536
      --  Chain clause to list of use clauses in current scope
2537
 
2538
      if Nkind (Parent (N)) /= N_Compilation_Unit then
2539
         Chain_Use_Clause (N);
2540
      end if;
2541
 
2542
      --  Loop through package names to identify referenced packages
2543
 
2544
      Pack_Name := First (Names (N));
2545
      while Present (Pack_Name) loop
2546
         Analyze (Pack_Name);
2547
 
2548
         if Nkind (Parent (N)) = N_Compilation_Unit
2549
           and then Nkind (Pack_Name) = N_Expanded_Name
2550
         then
2551
            declare
2552
               Pref : Node_Id;
2553
 
2554
            begin
2555
               Pref := Prefix (Pack_Name);
2556
               while Nkind (Pref) = N_Expanded_Name loop
2557
                  Pref := Prefix (Pref);
2558
               end loop;
2559
 
2560
               if Entity (Pref) = Standard_Standard then
2561
                  Error_Msg_N
2562
                   ("predefined package Standard cannot appear"
2563
                     & " in a context clause", Pref);
2564
               end if;
2565
            end;
2566
         end if;
2567
 
2568
         Next (Pack_Name);
2569
      end loop;
2570
 
2571
      --  Loop through package names to mark all entities as potentially
2572
      --  use visible.
2573
 
2574
      Pack_Name := First (Names (N));
2575
      while Present (Pack_Name) loop
2576
         if Is_Entity_Name (Pack_Name) then
2577
            Pack := Entity (Pack_Name);
2578
 
2579
            if Ekind (Pack) /= E_Package
2580
              and then Etype (Pack) /= Any_Type
2581
            then
2582
               if Ekind (Pack) = E_Generic_Package then
2583
                  Error_Msg_N  -- CODEFIX
2584
                   ("a generic package is not allowed in a use clause",
2585
                      Pack_Name);
2586
               else
2587
                  Error_Msg_N -- CODEFIX???
2588
                    ("& is not a usable package", Pack_Name);
2589
               end if;
2590
 
2591
            else
2592
               if Nkind (Parent (N)) = N_Compilation_Unit then
2593
                  Check_In_Previous_With_Clause (N, Pack_Name);
2594
               end if;
2595
 
2596
               if Applicable_Use (Pack_Name) then
2597
                  Use_One_Package (Pack, N);
2598
               end if;
2599
            end if;
2600
 
2601
         --  Report error because name denotes something other than a package
2602
 
2603
         else
2604
            Error_Msg_N ("& is not a package", Pack_Name);
2605
         end if;
2606
 
2607
         Next (Pack_Name);
2608
      end loop;
2609
   end Analyze_Use_Package;
2610
 
2611
   ----------------------
2612
   -- Analyze_Use_Type --
2613
   ----------------------
2614
 
2615
   procedure Analyze_Use_Type (N : Node_Id) is
2616
      E  : Entity_Id;
2617
      Id : Node_Id;
2618
 
2619
   begin
2620
      Set_Hidden_By_Use_Clause (N, No_Elist);
2621
 
2622
      --  Chain clause to list of use clauses in current scope
2623
 
2624
      if Nkind (Parent (N)) /= N_Compilation_Unit then
2625
         Chain_Use_Clause (N);
2626
      end if;
2627
 
2628
      Id := First (Subtype_Marks (N));
2629
      while Present (Id) loop
2630
         Find_Type (Id);
2631
         E := Entity (Id);
2632
 
2633
         if E /= Any_Type then
2634
            Use_One_Type (Id);
2635
 
2636
            if Nkind (Parent (N)) = N_Compilation_Unit then
2637
               if Nkind (Id) = N_Identifier then
2638
                  Error_Msg_N ("type is not directly visible", Id);
2639
 
2640
               elsif Is_Child_Unit (Scope (E))
2641
                 and then Scope (E) /= System_Aux_Id
2642
               then
2643
                  Check_In_Previous_With_Clause (N, Prefix (Id));
2644
               end if;
2645
            end if;
2646
 
2647
         else
2648
            --  If the use_type_clause appears in a compilation unit context,
2649
            --  check whether it comes from a unit that may appear in a
2650
            --  limited_with_clause, for a better error message.
2651
 
2652
            if Nkind (Parent (N)) = N_Compilation_Unit
2653
              and then Nkind (Id) /= N_Identifier
2654
            then
2655
               declare
2656
                  Item : Node_Id;
2657
                  Pref : Node_Id;
2658
 
2659
                  function Mentioned (Nam : Node_Id) return Boolean;
2660
                  --  Check whether the prefix of expanded name for the type
2661
                  --  appears in the prefix of some limited_with_clause.
2662
 
2663
                  ---------------
2664
                  -- Mentioned --
2665
                  ---------------
2666
 
2667
                  function Mentioned (Nam : Node_Id) return Boolean is
2668
                  begin
2669
                     return Nkind (Name (Item)) = N_Selected_Component
2670
                              and then
2671
                            Chars (Prefix (Name (Item))) = Chars (Nam);
2672
                  end Mentioned;
2673
 
2674
               begin
2675
                  Pref := Prefix (Id);
2676
                  Item := First (Context_Items (Parent (N)));
2677
 
2678
                  while Present (Item) and then Item /= N loop
2679
                     if Nkind (Item) = N_With_Clause
2680
                       and then Limited_Present (Item)
2681
                       and then Mentioned (Pref)
2682
                     then
2683
                        Change_Error_Text
2684
                          (Get_Msg_Id, "premature usage of incomplete type");
2685
                     end if;
2686
 
2687
                     Next (Item);
2688
                  end loop;
2689
               end;
2690
            end if;
2691
         end if;
2692
 
2693
         Next (Id);
2694
      end loop;
2695
   end Analyze_Use_Type;
2696
 
2697
   --------------------
2698
   -- Applicable_Use --
2699
   --------------------
2700
 
2701
   function Applicable_Use (Pack_Name : Node_Id) return Boolean is
2702
      Pack : constant Entity_Id := Entity (Pack_Name);
2703
 
2704
   begin
2705
      if In_Open_Scopes (Pack) then
2706
         if Warn_On_Redundant_Constructs
2707
           and then Pack = Current_Scope
2708
         then
2709
            Error_Msg_NE
2710
              ("& is already use-visible within itself?", Pack_Name, Pack);
2711
         end if;
2712
 
2713
         return False;
2714
 
2715
      elsif In_Use (Pack) then
2716
         Note_Redundant_Use (Pack_Name);
2717
         return False;
2718
 
2719
      elsif Present (Renamed_Object (Pack))
2720
        and then In_Use (Renamed_Object (Pack))
2721
      then
2722
         Note_Redundant_Use (Pack_Name);
2723
         return False;
2724
 
2725
      else
2726
         return True;
2727
      end if;
2728
   end Applicable_Use;
2729
 
2730
   ------------------------
2731
   -- Attribute_Renaming --
2732
   ------------------------
2733
 
2734
   procedure Attribute_Renaming (N : Node_Id) is
2735
      Loc        : constant Source_Ptr := Sloc (N);
2736
      Nam        : constant Node_Id    := Name (N);
2737
      Spec       : constant Node_Id    := Specification (N);
2738
      New_S      : constant Entity_Id  := Defining_Unit_Name (Spec);
2739
      Aname      : constant Name_Id    := Attribute_Name (Nam);
2740
 
2741
      Form_Num   : Nat      := 0;
2742
      Expr_List  : List_Id  := No_List;
2743
 
2744
      Attr_Node  : Node_Id;
2745
      Body_Node  : Node_Id;
2746
      Param_Spec : Node_Id;
2747
 
2748
   begin
2749
      Generate_Definition (New_S);
2750
 
2751
      --  This procedure is called in the context of subprogram renaming, and
2752
      --  thus the attribute must be one that is a subprogram. All of those
2753
      --  have at least one formal parameter, with the singular exception of
2754
      --  AST_Entry (which is a real oddity, it is odd that this can be renamed
2755
      --  at all!)
2756
 
2757
      if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then
2758
         if Aname /= Name_AST_Entry then
2759
            Error_Msg_N
2760
              ("subprogram renaming an attribute must have formals", N);
2761
            return;
2762
         end if;
2763
 
2764
      else
2765
         Param_Spec := First (Parameter_Specifications (Spec));
2766
         while Present (Param_Spec) loop
2767
            Form_Num := Form_Num + 1;
2768
 
2769
            if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
2770
               Find_Type (Parameter_Type (Param_Spec));
2771
 
2772
               --  The profile of the new entity denotes the base type (s) of
2773
               --  the types given in the specification. For access parameters
2774
               --  there are no subtypes involved.
2775
 
2776
               Rewrite (Parameter_Type (Param_Spec),
2777
                New_Reference_To
2778
                  (Base_Type (Entity (Parameter_Type (Param_Spec))), Loc));
2779
            end if;
2780
 
2781
            if No (Expr_List) then
2782
               Expr_List := New_List;
2783
            end if;
2784
 
2785
            Append_To (Expr_List,
2786
              Make_Identifier (Loc,
2787
                Chars => Chars (Defining_Identifier (Param_Spec))));
2788
 
2789
            --  The expressions in the attribute reference are not freeze
2790
            --  points. Neither is the attribute as a whole, see below.
2791
 
2792
            Set_Must_Not_Freeze (Last (Expr_List));
2793
            Next (Param_Spec);
2794
         end loop;
2795
      end if;
2796
 
2797
      --  Immediate error if too many formals. Other mismatches in number or
2798
      --  types of parameters are detected when we analyze the body of the
2799
      --  subprogram that we construct.
2800
 
2801
      if Form_Num > 2 then
2802
         Error_Msg_N ("too many formals for attribute", N);
2803
 
2804
      --  Error if the attribute reference has expressions that look like
2805
      --  formal parameters.
2806
 
2807
      elsif Present (Expressions (Nam)) then
2808
         Error_Msg_N ("illegal expressions in attribute reference", Nam);
2809
 
2810
      elsif
2811
        Aname = Name_Compose      or else
2812
        Aname = Name_Exponent     or else
2813
        Aname = Name_Leading_Part or else
2814
        Aname = Name_Pos          or else
2815
        Aname = Name_Round        or else
2816
        Aname = Name_Scaling      or else
2817
        Aname = Name_Val
2818
      then
2819
         if Nkind (N) = N_Subprogram_Renaming_Declaration
2820
           and then Present (Corresponding_Formal_Spec (N))
2821
         then
2822
            Error_Msg_N
2823
              ("generic actual cannot be attribute involving universal type",
2824
               Nam);
2825
         else
2826
            Error_Msg_N
2827
              ("attribute involving a universal type cannot be renamed",
2828
               Nam);
2829
         end if;
2830
      end if;
2831
 
2832
      --  AST_Entry is an odd case. It doesn't really make much sense to allow
2833
      --  it to be renamed, but that's the DEC rule, so we have to do it right.
2834
      --  The point is that the AST_Entry call should be made now, and what the
2835
      --  function will return is the returned value.
2836
 
2837
      --  Note that there is no Expr_List in this case anyway
2838
 
2839
      if Aname = Name_AST_Entry then
2840
         declare
2841
            Ent  : Entity_Id;
2842
            Decl : Node_Id;
2843
 
2844
         begin
2845
            Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2846
 
2847
            Decl :=
2848
              Make_Object_Declaration (Loc,
2849
                Defining_Identifier => Ent,
2850
                Object_Definition =>
2851
                  New_Occurrence_Of (RTE (RE_AST_Handler), Loc),
2852
                Expression => Nam,
2853
                Constant_Present => True);
2854
 
2855
            Set_Assignment_OK (Decl, True);
2856
            Insert_Action (N, Decl);
2857
            Attr_Node := Make_Identifier (Loc, Chars (Ent));
2858
         end;
2859
 
2860
      --  For all other attributes, we rewrite the attribute node to have
2861
      --  a list of expressions corresponding to the subprogram formals.
2862
      --  A renaming declaration is not a freeze point, and the analysis of
2863
      --  the attribute reference should not freeze the type of the prefix.
2864
 
2865
      else
2866
         Attr_Node :=
2867
           Make_Attribute_Reference (Loc,
2868
             Prefix         => Prefix (Nam),
2869
             Attribute_Name => Aname,
2870
             Expressions    => Expr_List);
2871
 
2872
         Set_Must_Not_Freeze (Attr_Node);
2873
         Set_Must_Not_Freeze (Prefix (Nam));
2874
      end if;
2875
 
2876
      --  Case of renaming a function
2877
 
2878
      if Nkind (Spec) = N_Function_Specification then
2879
         if Is_Procedure_Attribute_Name (Aname) then
2880
            Error_Msg_N ("attribute can only be renamed as procedure", Nam);
2881
            return;
2882
         end if;
2883
 
2884
         Find_Type (Result_Definition (Spec));
2885
         Rewrite (Result_Definition (Spec),
2886
             New_Reference_To (
2887
               Base_Type (Entity (Result_Definition (Spec))), Loc));
2888
 
2889
         Body_Node :=
2890
           Make_Subprogram_Body (Loc,
2891
             Specification => Spec,
2892
             Declarations => New_List,
2893
             Handled_Statement_Sequence =>
2894
               Make_Handled_Sequence_Of_Statements (Loc,
2895
                   Statements => New_List (
2896
                     Make_Simple_Return_Statement (Loc,
2897
                       Expression => Attr_Node))));
2898
 
2899
      --  Case of renaming a procedure
2900
 
2901
      else
2902
         if not Is_Procedure_Attribute_Name (Aname) then
2903
            Error_Msg_N ("attribute can only be renamed as function", Nam);
2904
            return;
2905
         end if;
2906
 
2907
         Body_Node :=
2908
           Make_Subprogram_Body (Loc,
2909
             Specification => Spec,
2910
             Declarations => New_List,
2911
             Handled_Statement_Sequence =>
2912
               Make_Handled_Sequence_Of_Statements (Loc,
2913
                   Statements => New_List (Attr_Node)));
2914
      end if;
2915
 
2916
      --  In case of tagged types we add the body of the generated function to
2917
      --  the freezing actions of the type (because in the general case such
2918
      --  type is still not frozen). We exclude from this processing generic
2919
      --  formal subprograms found in instantiations and AST_Entry renamings.
2920
 
2921
      if not Present (Corresponding_Formal_Spec (N))
2922
        and then Etype (Nam) /= RTE (RE_AST_Handler)
2923
      then
2924
         declare
2925
            P : constant Entity_Id := Prefix (Nam);
2926
 
2927
         begin
2928
            Find_Type (P);
2929
 
2930
            if Is_Tagged_Type (Etype (P)) then
2931
               Ensure_Freeze_Node (Etype (P));
2932
               Append_Freeze_Action (Etype (P), Body_Node);
2933
            else
2934
               Rewrite (N, Body_Node);
2935
               Analyze (N);
2936
               Set_Etype (New_S, Base_Type (Etype (New_S)));
2937
            end if;
2938
         end;
2939
 
2940
      --  Generic formal subprograms or AST_Handler renaming
2941
 
2942
      else
2943
         Rewrite (N, Body_Node);
2944
         Analyze (N);
2945
         Set_Etype (New_S, Base_Type (Etype (New_S)));
2946
      end if;
2947
 
2948
      if Is_Compilation_Unit (New_S) then
2949
         Error_Msg_N
2950
           ("a library unit can only rename another library unit", N);
2951
      end if;
2952
 
2953
      --  We suppress elaboration warnings for the resulting entity, since
2954
      --  clearly they are not needed, and more particularly, in the case
2955
      --  of a generic formal subprogram, the resulting entity can appear
2956
      --  after the instantiation itself, and thus look like a bogus case
2957
      --  of access before elaboration.
2958
 
2959
      Set_Suppress_Elaboration_Warnings (New_S);
2960
 
2961
   end Attribute_Renaming;
2962
 
2963
   ----------------------
2964
   -- Chain_Use_Clause --
2965
   ----------------------
2966
 
2967
   procedure Chain_Use_Clause (N : Node_Id) is
2968
      Pack : Entity_Id;
2969
      Level : Int := Scope_Stack.Last;
2970
 
2971
   begin
2972
      if not Is_Compilation_Unit (Current_Scope)
2973
        or else not Is_Child_Unit (Current_Scope)
2974
      then
2975
         null;   --  Common case
2976
 
2977
      elsif Defining_Entity (Parent (N)) = Current_Scope then
2978
         null;   --  Common case for compilation unit
2979
 
2980
      else
2981
         --  If declaration appears in some other scope, it must be in some
2982
         --  parent unit when compiling a child.
2983
 
2984
         Pack := Defining_Entity (Parent (N));
2985
         if not In_Open_Scopes (Pack) then
2986
            null;  --  default as well
2987
 
2988
         else
2989
            --  Find entry for parent unit in scope stack
2990
 
2991
            while Scope_Stack.Table (Level).Entity /= Pack loop
2992
               Level := Level - 1;
2993
            end loop;
2994
         end if;
2995
      end if;
2996
 
2997
      Set_Next_Use_Clause (N,
2998
        Scope_Stack.Table (Level).First_Use_Clause);
2999
      Scope_Stack.Table (Level).First_Use_Clause := N;
3000
   end Chain_Use_Clause;
3001
 
3002
   ---------------------------
3003
   -- Check_Frozen_Renaming --
3004
   ---------------------------
3005
 
3006
   procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is
3007
      B_Node : Node_Id;
3008
      Old_S  : Entity_Id;
3009
 
3010
   begin
3011
      if Is_Frozen (Subp)
3012
        and then not Has_Completion (Subp)
3013
      then
3014
         B_Node :=
3015
           Build_Renamed_Body
3016
             (Parent (Declaration_Node (Subp)), Defining_Entity (N));
3017
 
3018
         if Is_Entity_Name (Name (N)) then
3019
            Old_S := Entity (Name (N));
3020
 
3021
            if not Is_Frozen (Old_S)
3022
              and then Operating_Mode /= Check_Semantics
3023
            then
3024
               Append_Freeze_Action (Old_S, B_Node);
3025
            else
3026
               Insert_After (N, B_Node);
3027
               Analyze (B_Node);
3028
            end if;
3029
 
3030
            if Is_Intrinsic_Subprogram (Old_S)
3031
              and then not In_Instance
3032
            then
3033
               Error_Msg_N
3034
                 ("subprogram used in renaming_as_body cannot be intrinsic",
3035
                    Name (N));
3036
            end if;
3037
 
3038
         else
3039
            Insert_After (N, B_Node);
3040
            Analyze (B_Node);
3041
         end if;
3042
      end if;
3043
   end Check_Frozen_Renaming;
3044
 
3045
   -----------------------------------
3046
   -- Check_In_Previous_With_Clause --
3047
   -----------------------------------
3048
 
3049
   procedure Check_In_Previous_With_Clause
3050
     (N   : Node_Id;
3051
      Nam : Entity_Id)
3052
   is
3053
      Pack : constant Entity_Id := Entity (Original_Node (Nam));
3054
      Item : Node_Id;
3055
      Par  : Node_Id;
3056
 
3057
   begin
3058
      Item := First (Context_Items (Parent (N)));
3059
 
3060
      while Present (Item)
3061
        and then Item /= N
3062
      loop
3063
         if Nkind (Item) = N_With_Clause
3064
 
3065
            --  Protect the frontend against previous critical errors
3066
 
3067
           and then Nkind (Name (Item)) /= N_Selected_Component
3068
           and then Entity (Name (Item)) = Pack
3069
         then
3070
            Par := Nam;
3071
 
3072
            --  Find root library unit in with_clause
3073
 
3074
            while Nkind (Par) = N_Expanded_Name loop
3075
               Par := Prefix (Par);
3076
            end loop;
3077
 
3078
            if Is_Child_Unit (Entity (Original_Node (Par))) then
3079
               Error_Msg_NE
3080
                 ("& is not directly visible", Par, Entity (Par));
3081
            else
3082
               return;
3083
            end if;
3084
         end if;
3085
 
3086
         Next (Item);
3087
      end loop;
3088
 
3089
      --  On exit, package is not mentioned in a previous with_clause.
3090
      --  Check if its prefix is.
3091
 
3092
      if Nkind (Nam) = N_Expanded_Name then
3093
         Check_In_Previous_With_Clause (N, Prefix (Nam));
3094
 
3095
      elsif Pack /= Any_Id then
3096
         Error_Msg_NE ("& is not visible", Nam, Pack);
3097
      end if;
3098
   end Check_In_Previous_With_Clause;
3099
 
3100
   ---------------------------------
3101
   -- Check_Library_Unit_Renaming --
3102
   ---------------------------------
3103
 
3104
   procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id) is
3105
      New_E : Entity_Id;
3106
 
3107
   begin
3108
      if Nkind (Parent (N)) /= N_Compilation_Unit then
3109
         return;
3110
 
3111
      --  Check for library unit. Note that we used to check for the scope
3112
      --  being Standard here, but that was wrong for Standard itself.
3113
 
3114
      elsif not Is_Compilation_Unit (Old_E)
3115
        and then not Is_Child_Unit (Old_E)
3116
      then
3117
         Error_Msg_N ("renamed unit must be a library unit", Name (N));
3118
 
3119
      --  Entities defined in Standard (operators and boolean literals) cannot
3120
      --  be renamed as library units.
3121
 
3122
      elsif Scope (Old_E) = Standard_Standard
3123
        and then Sloc (Old_E) = Standard_Location
3124
      then
3125
         Error_Msg_N ("renamed unit must be a library unit", Name (N));
3126
 
3127
      elsif Present (Parent_Spec (N))
3128
        and then Nkind (Unit (Parent_Spec (N))) = N_Generic_Package_Declaration
3129
        and then not Is_Child_Unit (Old_E)
3130
      then
3131
         Error_Msg_N
3132
           ("renamed unit must be a child unit of generic parent", Name (N));
3133
 
3134
      elsif Nkind (N) in N_Generic_Renaming_Declaration
3135
         and then  Nkind (Name (N)) = N_Expanded_Name
3136
         and then Is_Generic_Instance (Entity (Prefix (Name (N))))
3137
         and then Is_Generic_Unit (Old_E)
3138
      then
3139
         Error_Msg_N
3140
           ("renamed generic unit must be a library unit", Name (N));
3141
 
3142
      elsif Is_Package_Or_Generic_Package (Old_E) then
3143
 
3144
         --  Inherit categorization flags
3145
 
3146
         New_E := Defining_Entity (N);
3147
         Set_Is_Pure                  (New_E, Is_Pure           (Old_E));
3148
         Set_Is_Preelaborated         (New_E, Is_Preelaborated  (Old_E));
3149
         Set_Is_Remote_Call_Interface (New_E,
3150
                                       Is_Remote_Call_Interface (Old_E));
3151
         Set_Is_Remote_Types          (New_E, Is_Remote_Types   (Old_E));
3152
         Set_Is_Shared_Passive        (New_E, Is_Shared_Passive (Old_E));
3153
      end if;
3154
   end Check_Library_Unit_Renaming;
3155
 
3156
   ---------------
3157
   -- End_Scope --
3158
   ---------------
3159
 
3160
   procedure End_Scope is
3161
      Id    : Entity_Id;
3162
      Prev  : Entity_Id;
3163
      Outer : Entity_Id;
3164
 
3165
   begin
3166
      Id := First_Entity (Current_Scope);
3167
      while Present (Id) loop
3168
         --  An entity in the current scope is not necessarily the first one
3169
         --  on its homonym chain. Find its predecessor if any,
3170
         --  If it is an internal entity, it will not be in the visibility
3171
         --  chain altogether,  and there is nothing to unchain.
3172
 
3173
         if Id /= Current_Entity (Id) then
3174
            Prev := Current_Entity (Id);
3175
            while Present (Prev)
3176
              and then Present (Homonym (Prev))
3177
              and then Homonym (Prev) /= Id
3178
            loop
3179
               Prev := Homonym (Prev);
3180
            end loop;
3181
 
3182
            --  Skip to end of loop if Id is not in the visibility chain
3183
 
3184
            if No (Prev) or else Homonym (Prev) /= Id then
3185
               goto Next_Ent;
3186
            end if;
3187
 
3188
         else
3189
            Prev := Empty;
3190
         end if;
3191
 
3192
         Set_Is_Immediately_Visible (Id, False);
3193
 
3194
         Outer := Homonym (Id);
3195
         while Present (Outer) and then Scope (Outer) = Current_Scope loop
3196
            Outer := Homonym (Outer);
3197
         end loop;
3198
 
3199
         --  Reset homonym link of other entities, but do not modify link
3200
         --  between entities in current scope, so that the back-end can have
3201
         --  a proper count of local overloadings.
3202
 
3203
         if No (Prev) then
3204
            Set_Name_Entity_Id (Chars (Id), Outer);
3205
 
3206
         elsif Scope (Prev) /= Scope (Id) then
3207
            Set_Homonym (Prev,  Outer);
3208
         end if;
3209
 
3210
         <<Next_Ent>>
3211
            Next_Entity (Id);
3212
      end loop;
3213
 
3214
      --  If the scope generated freeze actions, place them before the
3215
      --  current declaration and analyze them. Type declarations and
3216
      --  the bodies of initialization procedures can generate such nodes.
3217
      --  We follow the parent chain until we reach a list node, which is
3218
      --  the enclosing list of declarations. If the list appears within
3219
      --  a protected definition, move freeze nodes outside the protected
3220
      --  type altogether.
3221
 
3222
      if Present
3223
         (Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions)
3224
      then
3225
         declare
3226
            Decl : Node_Id;
3227
            L    : constant List_Id := Scope_Stack.Table
3228
                    (Scope_Stack.Last).Pending_Freeze_Actions;
3229
 
3230
         begin
3231
            if Is_Itype (Current_Scope) then
3232
               Decl := Associated_Node_For_Itype (Current_Scope);
3233
            else
3234
               Decl := Parent (Current_Scope);
3235
            end if;
3236
 
3237
            Pop_Scope;
3238
 
3239
            while not (Is_List_Member (Decl))
3240
              or else Nkind_In (Parent (Decl), N_Protected_Definition,
3241
                                               N_Task_Definition)
3242
            loop
3243
               Decl := Parent (Decl);
3244
            end loop;
3245
 
3246
            Insert_List_Before_And_Analyze (Decl, L);
3247
         end;
3248
 
3249
      else
3250
         Pop_Scope;
3251
      end if;
3252
 
3253
   end End_Scope;
3254
 
3255
   ---------------------
3256
   -- End_Use_Clauses --
3257
   ---------------------
3258
 
3259
   procedure End_Use_Clauses (Clause : Node_Id) is
3260
      U   : Node_Id;
3261
 
3262
   begin
3263
      --  Remove Use_Type clauses first, because they affect the
3264
      --  visibility of operators in subsequent used packages.
3265
 
3266
      U := Clause;
3267
      while Present (U) loop
3268
         if Nkind (U) = N_Use_Type_Clause then
3269
            End_Use_Type (U);
3270
         end if;
3271
 
3272
         Next_Use_Clause (U);
3273
      end loop;
3274
 
3275
      U := Clause;
3276
      while Present (U) loop
3277
         if Nkind (U) = N_Use_Package_Clause then
3278
            End_Use_Package (U);
3279
         end if;
3280
 
3281
         Next_Use_Clause (U);
3282
      end loop;
3283
   end End_Use_Clauses;
3284
 
3285
   ---------------------
3286
   -- End_Use_Package --
3287
   ---------------------
3288
 
3289
   procedure End_Use_Package (N : Node_Id) is
3290
      Pack_Name : Node_Id;
3291
      Pack      : Entity_Id;
3292
      Id        : Entity_Id;
3293
      Elmt      : Elmt_Id;
3294
 
3295
      function Is_Primitive_Operator
3296
        (Op : Entity_Id;
3297
         F  : Entity_Id) return Boolean;
3298
      --  Check whether Op is a primitive operator of a use-visible type
3299
 
3300
      ---------------------------
3301
      -- Is_Primitive_Operator --
3302
      ---------------------------
3303
 
3304
      function Is_Primitive_Operator
3305
        (Op : Entity_Id;
3306
         F  : Entity_Id) return Boolean
3307
      is
3308
         T : constant Entity_Id := Etype (F);
3309
      begin
3310
         return In_Use (T)
3311
           and then Scope (T) = Scope (Op);
3312
      end Is_Primitive_Operator;
3313
 
3314
   --  Start of processing for End_Use_Package
3315
 
3316
   begin
3317
      Pack_Name := First (Names (N));
3318
      while Present (Pack_Name) loop
3319
 
3320
         --  Test that Pack_Name actually denotes a package before processing
3321
 
3322
         if Is_Entity_Name (Pack_Name)
3323
           and then Ekind (Entity (Pack_Name)) = E_Package
3324
         then
3325
            Pack := Entity (Pack_Name);
3326
 
3327
            if In_Open_Scopes (Pack) then
3328
               null;
3329
 
3330
            elsif not Redundant_Use (Pack_Name) then
3331
               Set_In_Use (Pack, False);
3332
               Set_Current_Use_Clause (Pack, Empty);
3333
 
3334
               Id := First_Entity (Pack);
3335
               while Present (Id) loop
3336
 
3337
                  --  Preserve use-visibility of operators that are primitive
3338
                  --  operators of a type that is use-visible through an active
3339
                  --  use_type clause.
3340
 
3341
                  if Nkind (Id) = N_Defining_Operator_Symbol
3342
                       and then
3343
                         (Is_Primitive_Operator (Id, First_Formal (Id))
3344
                            or else
3345
                          (Present (Next_Formal (First_Formal (Id)))
3346
                             and then
3347
                               Is_Primitive_Operator
3348
                                 (Id, Next_Formal (First_Formal (Id)))))
3349
                  then
3350
                     null;
3351
 
3352
                  else
3353
                     Set_Is_Potentially_Use_Visible (Id, False);
3354
                  end if;
3355
 
3356
                  if Is_Private_Type (Id)
3357
                    and then Present (Full_View (Id))
3358
                  then
3359
                     Set_Is_Potentially_Use_Visible (Full_View (Id), False);
3360
                  end if;
3361
 
3362
                  Next_Entity (Id);
3363
               end loop;
3364
 
3365
               if Present (Renamed_Object (Pack)) then
3366
                  Set_In_Use (Renamed_Object (Pack), False);
3367
                  Set_Current_Use_Clause (Renamed_Object (Pack), Empty);
3368
               end if;
3369
 
3370
               if Chars (Pack) = Name_System
3371
                 and then Scope (Pack) = Standard_Standard
3372
                 and then Present_System_Aux
3373
               then
3374
                  Id := First_Entity (System_Aux_Id);
3375
                  while Present (Id) loop
3376
                     Set_Is_Potentially_Use_Visible (Id, False);
3377
 
3378
                     if Is_Private_Type (Id)
3379
                       and then Present (Full_View (Id))
3380
                     then
3381
                        Set_Is_Potentially_Use_Visible (Full_View (Id), False);
3382
                     end if;
3383
 
3384
                     Next_Entity (Id);
3385
                  end loop;
3386
 
3387
                  Set_In_Use (System_Aux_Id, False);
3388
               end if;
3389
 
3390
            else
3391
               Set_Redundant_Use (Pack_Name, False);
3392
            end if;
3393
         end if;
3394
 
3395
         Next (Pack_Name);
3396
      end loop;
3397
 
3398
      if Present (Hidden_By_Use_Clause (N)) then
3399
         Elmt := First_Elmt (Hidden_By_Use_Clause (N));
3400
         while Present (Elmt) loop
3401
            declare
3402
               E : constant Entity_Id := Node (Elmt);
3403
 
3404
            begin
3405
               --  Reset either Use_Visibility or Direct_Visibility, depending
3406
               --  on how the entity was hidden by the use clause.
3407
 
3408
               if In_Use (Scope (E))
3409
                 and then Used_As_Generic_Actual (Scope (E))
3410
               then
3411
                  Set_Is_Potentially_Use_Visible (Node (Elmt));
3412
               else
3413
                  Set_Is_Immediately_Visible (Node (Elmt));
3414
               end if;
3415
 
3416
               Next_Elmt (Elmt);
3417
            end;
3418
         end loop;
3419
 
3420
         Set_Hidden_By_Use_Clause (N, No_Elist);
3421
      end if;
3422
   end End_Use_Package;
3423
 
3424
   ------------------
3425
   -- End_Use_Type --
3426
   ------------------
3427
 
3428
   procedure End_Use_Type (N : Node_Id) is
3429
      Id      : Entity_Id;
3430
      Op_List : Elist_Id;
3431
      Elmt    : Elmt_Id;
3432
      T       : Entity_Id;
3433
 
3434
   begin
3435
      Id := First (Subtype_Marks (N));
3436
      while Present (Id) loop
3437
 
3438
         --  A call to rtsfind may occur while analyzing a use_type clause,
3439
         --  in which case the type marks are not resolved yet, and there is
3440
         --  nothing to remove.
3441
 
3442
         if not Is_Entity_Name (Id)
3443
           or else No (Entity (Id))
3444
         then
3445
            goto Continue;
3446
         end if;
3447
 
3448
         T := Entity (Id);
3449
 
3450
         if T = Any_Type
3451
           or else From_With_Type (T)
3452
         then
3453
            null;
3454
 
3455
         --  Note that the use_Type clause may mention a subtype of the type
3456
         --  whose primitive operations have been made visible. Here as
3457
         --  elsewhere, it is the base type that matters for visibility.
3458
 
3459
         elsif In_Open_Scopes (Scope (Base_Type (T))) then
3460
            null;
3461
 
3462
         elsif not Redundant_Use (Id) then
3463
            Set_In_Use (T, False);
3464
            Set_In_Use (Base_Type (T), False);
3465
            Set_Current_Use_Clause (T, Empty);
3466
            Set_Current_Use_Clause (Base_Type (T), Empty);
3467
            Op_List := Collect_Primitive_Operations (T);
3468
 
3469
            Elmt := First_Elmt (Op_List);
3470
            while Present (Elmt) loop
3471
               if Nkind (Node (Elmt)) = N_Defining_Operator_Symbol then
3472
                  Set_Is_Potentially_Use_Visible (Node (Elmt), False);
3473
               end if;
3474
 
3475
               Next_Elmt (Elmt);
3476
            end loop;
3477
         end if;
3478
 
3479
         <<Continue>>
3480
         Next (Id);
3481
      end loop;
3482
   end End_Use_Type;
3483
 
3484
   ----------------------
3485
   -- Find_Direct_Name --
3486
   ----------------------
3487
 
3488
   procedure Find_Direct_Name (N : Node_Id) is
3489
      E    : Entity_Id;
3490
      E2   : Entity_Id;
3491
      Msg  : Boolean;
3492
 
3493
      Inst : Entity_Id := Empty;
3494
      --  Enclosing instance, if any
3495
 
3496
      Homonyms : Entity_Id;
3497
      --  Saves start of homonym chain
3498
 
3499
      Nvis_Entity : Boolean;
3500
      --  Set True to indicate that there is at least one entity on the homonym
3501
      --  chain which, while not visible, is visible enough from the user point
3502
      --  of view to warrant an error message of "not visible" rather than
3503
      --  undefined.
3504
 
3505
      Nvis_Is_Private_Subprg : Boolean := False;
3506
      --  Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais
3507
      --  effect concerning library subprograms has been detected. Used to
3508
      --  generate the precise error message.
3509
 
3510
      function From_Actual_Package (E : Entity_Id) return Boolean;
3511
      --  Returns true if the entity is declared in a package that is
3512
      --  an actual for a formal package of the current instance. Such an
3513
      --  entity requires special handling because it may be use-visible
3514
      --  but hides directly visible entities defined outside the instance.
3515
 
3516
      function Is_Actual_Parameter return Boolean;
3517
      --  This function checks if the node N is an identifier that is an actual
3518
      --  parameter of a procedure call. If so it returns True, otherwise it
3519
      --  return False. The reason for this check is that at this stage we do
3520
      --  not know what procedure is being called if the procedure might be
3521
      --  overloaded, so it is premature to go setting referenced flags or
3522
      --  making calls to Generate_Reference. We will wait till Resolve_Actuals
3523
      --  for that processing
3524
 
3525
      function Known_But_Invisible (E : Entity_Id) return Boolean;
3526
      --  This function determines whether the entity E (which is not
3527
      --  visible) can reasonably be considered to be known to the writer
3528
      --  of the reference. This is a heuristic test, used only for the
3529
      --  purposes of figuring out whether we prefer to complain that an
3530
      --  entity is undefined or invisible (and identify the declaration
3531
      --  of the invisible entity in the latter case). The point here is
3532
      --  that we don't want to complain that something is invisible and
3533
      --  then point to something entirely mysterious to the writer.
3534
 
3535
      procedure Nvis_Messages;
3536
      --  Called if there are no visible entries for N, but there is at least
3537
      --  one non-directly visible, or hidden declaration. This procedure
3538
      --  outputs an appropriate set of error messages.
3539
 
3540
      procedure Undefined (Nvis : Boolean);
3541
      --  This function is called if the current node has no corresponding
3542
      --  visible entity or entities. The value set in Msg indicates whether
3543
      --  an error message was generated (multiple error messages for the
3544
      --  same variable are generally suppressed, see body for details).
3545
      --  Msg is True if an error message was generated, False if not. This
3546
      --  value is used by the caller to determine whether or not to output
3547
      --  additional messages where appropriate. The parameter is set False
3548
      --  to get the message "X is undefined", and True to get the message
3549
      --  "X is not visible".
3550
 
3551
      -------------------------
3552
      -- From_Actual_Package --
3553
      -------------------------
3554
 
3555
      function From_Actual_Package (E : Entity_Id) return Boolean is
3556
         Scop : constant Entity_Id := Scope (E);
3557
         Act  : Entity_Id;
3558
 
3559
      begin
3560
         if not In_Instance then
3561
            return False;
3562
         else
3563
            Inst := Current_Scope;
3564
            while Present (Inst)
3565
              and then Ekind (Inst) /= E_Package
3566
              and then not Is_Generic_Instance (Inst)
3567
            loop
3568
               Inst := Scope (Inst);
3569
            end loop;
3570
 
3571
            if No (Inst) then
3572
               return False;
3573
            end if;
3574
 
3575
            Act := First_Entity (Inst);
3576
            while Present (Act) loop
3577
               if Ekind (Act) = E_Package then
3578
 
3579
                  --  Check for end of actuals list
3580
 
3581
                  if Renamed_Object (Act) = Inst then
3582
                     return False;
3583
 
3584
                  elsif Present (Associated_Formal_Package (Act))
3585
                    and then Renamed_Object (Act) = Scop
3586
                  then
3587
                     --  Entity comes from (instance of) formal package
3588
 
3589
                     return True;
3590
 
3591
                  else
3592
                     Next_Entity (Act);
3593
                  end if;
3594
 
3595
               else
3596
                  Next_Entity (Act);
3597
               end if;
3598
            end loop;
3599
 
3600
            return False;
3601
         end if;
3602
      end From_Actual_Package;
3603
 
3604
      -------------------------
3605
      -- Is_Actual_Parameter --
3606
      -------------------------
3607
 
3608
      function Is_Actual_Parameter return Boolean is
3609
      begin
3610
         return
3611
           Nkind (N) = N_Identifier
3612
             and then
3613
               (Nkind (Parent (N)) = N_Procedure_Call_Statement
3614
                  or else
3615
                    (Nkind (Parent (N)) = N_Parameter_Association
3616
                       and then N = Explicit_Actual_Parameter (Parent (N))
3617
                       and then Nkind (Parent (Parent (N))) =
3618
                                          N_Procedure_Call_Statement));
3619
      end Is_Actual_Parameter;
3620
 
3621
      -------------------------
3622
      -- Known_But_Invisible --
3623
      -------------------------
3624
 
3625
      function Known_But_Invisible (E : Entity_Id) return Boolean is
3626
         Fname : File_Name_Type;
3627
 
3628
      begin
3629
         --  Entities in Standard are always considered to be known
3630
 
3631
         if Sloc (E) <= Standard_Location then
3632
            return True;
3633
 
3634
         --  An entity that does not come from source is always considered
3635
         --  to be unknown, since it is an artifact of code expansion.
3636
 
3637
         elsif not Comes_From_Source (E) then
3638
            return False;
3639
 
3640
         --  In gnat internal mode, we consider all entities known
3641
 
3642
         elsif GNAT_Mode then
3643
            return True;
3644
         end if;
3645
 
3646
         --  Here we have an entity that is not from package Standard, and
3647
         --  which comes from Source. See if it comes from an internal file.
3648
 
3649
         Fname := Unit_File_Name (Get_Source_Unit (E));
3650
 
3651
         --  Case of from internal file
3652
 
3653
         if Is_Internal_File_Name (Fname) then
3654
 
3655
            --  Private part entities in internal files are never considered
3656
            --  to be known to the writer of normal application code.
3657
 
3658
            if Is_Hidden (E) then
3659
               return False;
3660
            end if;
3661
 
3662
            --  Entities from System packages other than System and
3663
            --  System.Storage_Elements are not considered to be known.
3664
            --  System.Auxxxx files are also considered known to the user.
3665
 
3666
            --  Should refine this at some point to generally distinguish
3667
            --  between known and unknown internal files ???
3668
 
3669
            Get_Name_String (Fname);
3670
 
3671
            return
3672
              Name_Len < 2
3673
                or else
3674
              Name_Buffer (1 .. 2) /= "s-"
3675
                or else
3676
              Name_Buffer (3 .. 8) = "stoele"
3677
                or else
3678
              Name_Buffer (3 .. 5) = "aux";
3679
 
3680
         --  If not an internal file, then entity is definitely known,
3681
         --  even if it is in a private part (the message generated will
3682
         --  note that it is in a private part)
3683
 
3684
         else
3685
            return True;
3686
         end if;
3687
      end Known_But_Invisible;
3688
 
3689
      -------------------
3690
      -- Nvis_Messages --
3691
      -------------------
3692
 
3693
      procedure Nvis_Messages is
3694
         Comp_Unit : Node_Id;
3695
         Ent       : Entity_Id;
3696
         Found     : Boolean := False;
3697
         Hidden    : Boolean := False;
3698
         Item      : Node_Id;
3699
 
3700
      begin
3701
         --  Ada 2005 (AI-262): Generate a precise error concerning the
3702
         --  Beaujolais effect that was previously detected
3703
 
3704
         if Nvis_Is_Private_Subprg then
3705
 
3706
            pragma Assert (Nkind (E2) = N_Defining_Identifier
3707
                            and then Ekind (E2) = E_Function
3708
                            and then Scope (E2) = Standard_Standard
3709
                            and then Has_Private_With (E2));
3710
 
3711
            --  Find the sloc corresponding to the private with'ed unit
3712
 
3713
            Comp_Unit := Cunit (Current_Sem_Unit);
3714
            Error_Msg_Sloc := No_Location;
3715
 
3716
            Item := First (Context_Items (Comp_Unit));
3717
            while Present (Item) loop
3718
               if Nkind (Item) = N_With_Clause
3719
                 and then Private_Present (Item)
3720
                 and then Entity (Name (Item)) = E2
3721
               then
3722
                  Error_Msg_Sloc := Sloc (Item);
3723
                  exit;
3724
               end if;
3725
 
3726
               Next (Item);
3727
            end loop;
3728
 
3729
            pragma Assert (Error_Msg_Sloc /= No_Location);
3730
 
3731
            Error_Msg_N ("(Ada 2005): hidden by private with clause #", N);
3732
            return;
3733
         end if;
3734
 
3735
         Undefined (Nvis => True);
3736
 
3737
         if Msg then
3738
 
3739
            --  First loop does hidden declarations
3740
 
3741
            Ent := Homonyms;
3742
            while Present (Ent) loop
3743
               if Is_Potentially_Use_Visible (Ent) then
3744
                  if not Hidden then
3745
                     Error_Msg_N -- CODEFIX
3746
                       ("multiple use clauses cause hiding!", N);
3747
                     Hidden := True;
3748
                  end if;
3749
 
3750
                  Error_Msg_Sloc := Sloc (Ent);
3751
                  Error_Msg_N -- CODEFIX
3752
                    ("hidden declaration#!", N);
3753
               end if;
3754
 
3755
               Ent := Homonym (Ent);
3756
            end loop;
3757
 
3758
            --  If we found hidden declarations, then that's enough, don't
3759
            --  bother looking for non-visible declarations as well.
3760
 
3761
            if Hidden then
3762
               return;
3763
            end if;
3764
 
3765
            --  Second loop does non-directly visible declarations
3766
 
3767
            Ent := Homonyms;
3768
            while Present (Ent) loop
3769
               if not Is_Potentially_Use_Visible (Ent) then
3770
 
3771
                  --  Do not bother the user with unknown entities
3772
 
3773
                  if not Known_But_Invisible (Ent) then
3774
                     goto Continue;
3775
                  end if;
3776
 
3777
                  Error_Msg_Sloc := Sloc (Ent);
3778
 
3779
                  --  Output message noting that there is a non-visible
3780
                  --  declaration, distinguishing the private part case.
3781
 
3782
                  if Is_Hidden (Ent) then
3783
                     Error_Msg_N ("non-visible (private) declaration#!", N);
3784
 
3785
                  --  If the entity is declared in a generic package, it
3786
                  --  cannot be visible, so there is no point in adding it
3787
                  --  to the list of candidates if another homograph from a
3788
                  --  non-generic package has been seen.
3789
 
3790
                  elsif Ekind (Scope (Ent)) = E_Generic_Package
3791
                    and then Found
3792
                  then
3793
                     null;
3794
 
3795
                  else
3796
                     Error_Msg_N -- CODEFIX
3797
                       ("non-visible declaration#!", N);
3798
 
3799
                     if Ekind (Scope (Ent)) /= E_Generic_Package then
3800
                        Found := True;
3801
                     end if;
3802
 
3803
                     if Is_Compilation_Unit (Ent)
3804
                       and then
3805
                         Nkind (Parent (Parent (N))) = N_Use_Package_Clause
3806
                     then
3807
                        Error_Msg_Qual_Level := 99;
3808
                        Error_Msg_NE ("\\missing `WITH &;`", N, Ent);
3809
                        Error_Msg_Qual_Level := 0;
3810
                     end if;
3811
                  end if;
3812
 
3813
                  --  Set entity and its containing package as referenced. We
3814
                  --  can't be sure of this, but this seems a better choice
3815
                  --  to avoid unused entity messages.
3816
 
3817
                  if Comes_From_Source (Ent) then
3818
                     Set_Referenced (Ent);
3819
                     Set_Referenced (Cunit_Entity (Get_Source_Unit (Ent)));
3820
                  end if;
3821
               end if;
3822
 
3823
               <<Continue>>
3824
               Ent := Homonym (Ent);
3825
            end loop;
3826
         end if;
3827
      end Nvis_Messages;
3828
 
3829
      ---------------
3830
      -- Undefined --
3831
      ---------------
3832
 
3833
      procedure Undefined (Nvis : Boolean) is
3834
         Emsg : Error_Msg_Id;
3835
 
3836
      begin
3837
         --  We should never find an undefined internal name. If we do, then
3838
         --  see if we have previous errors. If so, ignore on the grounds that
3839
         --  it is probably a cascaded message (e.g. a block label from a badly
3840
         --  formed block). If no previous errors, then we have a real internal
3841
         --  error of some kind so raise an exception.
3842
 
3843
         if Is_Internal_Name (Chars (N)) then
3844
            if Total_Errors_Detected /= 0 then
3845
               return;
3846
            else
3847
               raise Program_Error;
3848
            end if;
3849
         end if;
3850
 
3851
         --  A very specialized error check, if the undefined variable is
3852
         --  a case tag, and the case type is an enumeration type, check
3853
         --  for a possible misspelling, and if so, modify the identifier
3854
 
3855
         --  Named aggregate should also be handled similarly ???
3856
 
3857
         if Nkind (N) = N_Identifier
3858
           and then Nkind (Parent (N)) = N_Case_Statement_Alternative
3859
         then
3860
            declare
3861
               Case_Stm : constant Node_Id   := Parent (Parent (N));
3862
               Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm));
3863
 
3864
               Lit : Node_Id;
3865
 
3866
            begin
3867
               if Is_Enumeration_Type (Case_Typ)
3868
                 and then not Is_Standard_Character_Type (Case_Typ)
3869
               then
3870
                  Lit := First_Literal (Case_Typ);
3871
                  Get_Name_String (Chars (Lit));
3872
 
3873
                  if Chars (Lit) /= Chars (N)
3874
                    and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) then
3875
                     Error_Msg_Node_2 := Lit;
3876
                     Error_Msg_N
3877
                       ("& is undefined, assume misspelling of &", N);
3878
                     Rewrite (N, New_Occurrence_Of (Lit, Sloc (N)));
3879
                     return;
3880
                  end if;
3881
 
3882
                  Lit := Next_Literal (Lit);
3883
               end if;
3884
            end;
3885
         end if;
3886
 
3887
         --  Normal processing
3888
 
3889
         Set_Entity (N, Any_Id);
3890
         Set_Etype  (N, Any_Type);
3891
 
3892
         --  We use the table Urefs to keep track of entities for which we
3893
         --  have issued errors for undefined references. Multiple errors
3894
         --  for a single name are normally suppressed, however we modify
3895
         --  the error message to alert the programmer to this effect.
3896
 
3897
         for J in Urefs.First .. Urefs.Last loop
3898
            if Chars (N) = Chars (Urefs.Table (J).Node) then
3899
               if Urefs.Table (J).Err /= No_Error_Msg
3900
                 and then Sloc (N) /= Urefs.Table (J).Loc
3901
               then
3902
                  Error_Msg_Node_1 := Urefs.Table (J).Node;
3903
 
3904
                  if Urefs.Table (J).Nvis then
3905
                     Change_Error_Text (Urefs.Table (J).Err,
3906
                       "& is not visible (more references follow)");
3907
                  else
3908
                     Change_Error_Text (Urefs.Table (J).Err,
3909
                       "& is undefined (more references follow)");
3910
                  end if;
3911
 
3912
                  Urefs.Table (J).Err := No_Error_Msg;
3913
               end if;
3914
 
3915
               --  Although we will set Msg False, and thus suppress the
3916
               --  message, we also set Error_Posted True, to avoid any
3917
               --  cascaded messages resulting from the undefined reference.
3918
 
3919
               Msg := False;
3920
               Set_Error_Posted (N, True);
3921
               return;
3922
            end if;
3923
         end loop;
3924
 
3925
         --  If entry not found, this is first undefined occurrence
3926
 
3927
         if Nvis then
3928
            Error_Msg_N ("& is not visible!", N);
3929
            Emsg := Get_Msg_Id;
3930
 
3931
         else
3932
            Error_Msg_N ("& is undefined!", N);
3933
            Emsg := Get_Msg_Id;
3934
 
3935
            --  A very bizarre special check, if the undefined identifier
3936
            --  is put or put_line, then add a special error message (since
3937
            --  this is a very common error for beginners to make).
3938
 
3939
            if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then
3940
               Error_Msg_N
3941
                 ("\\possible missing `WITH Ada.Text_'I'O; " &
3942
                  "USE Ada.Text_'I'O`!", N);
3943
 
3944
            --  Another special check if N is the prefix of a selected
3945
            --  component which is a known unit, add message complaining
3946
            --  about missing with for this unit.
3947
 
3948
            elsif Nkind (Parent (N)) = N_Selected_Component
3949
              and then N = Prefix (Parent (N))
3950
              and then Is_Known_Unit (Parent (N))
3951
            then
3952
               Error_Msg_Node_2 := Selector_Name (Parent (N));
3953
               Error_Msg_N ("\\missing `WITH &.&;`", Prefix (Parent (N)));
3954
            end if;
3955
 
3956
            --  Now check for possible misspellings
3957
 
3958
            declare
3959
               E      : Entity_Id;
3960
               Ematch : Entity_Id := Empty;
3961
 
3962
               Last_Name_Id : constant Name_Id :=
3963
                                Name_Id (Nat (First_Name_Id) +
3964
                                           Name_Entries_Count - 1);
3965
 
3966
            begin
3967
               for Nam in First_Name_Id .. Last_Name_Id loop
3968
                  E := Get_Name_Entity_Id (Nam);
3969
 
3970
                  if Present (E)
3971
                     and then (Is_Immediately_Visible (E)
3972
                                 or else
3973
                               Is_Potentially_Use_Visible (E))
3974
                  then
3975
                     if Is_Bad_Spelling_Of (Chars (N), Nam) then
3976
                        Ematch := E;
3977
                        exit;
3978
                     end if;
3979
                  end if;
3980
               end loop;
3981
 
3982
               if Present (Ematch) then
3983
                  Error_Msg_NE -- CODEFIX
3984
                    ("\possible misspelling of&", N, Ematch);
3985
               end if;
3986
            end;
3987
         end if;
3988
 
3989
         --  Make entry in undefined references table unless the full errors
3990
         --  switch is set, in which case by refraining from generating the
3991
         --  table entry, we guarantee that we get an error message for every
3992
         --  undefined reference.
3993
 
3994
         if not All_Errors_Mode then
3995
            Urefs.Append (
3996
              (Node => N,
3997
               Err  => Emsg,
3998
               Nvis => Nvis,
3999
               Loc  => Sloc (N)));
4000
         end if;
4001
 
4002
         Msg := True;
4003
      end Undefined;
4004
 
4005
   --  Start of processing for Find_Direct_Name
4006
 
4007
   begin
4008
      --  If the entity pointer is already set, this is an internal node, or
4009
      --  a node that is analyzed more than once, after a tree modification.
4010
      --  In such a case there is no resolution to perform, just set the type.
4011
 
4012
      if Present (Entity (N)) then
4013
         if Is_Type (Entity (N)) then
4014
            Set_Etype (N, Entity (N));
4015
 
4016
         else
4017
            declare
4018
               Entyp : constant Entity_Id := Etype (Entity (N));
4019
 
4020
            begin
4021
               --  One special case here. If the Etype field is already set,
4022
               --  and references the packed array type corresponding to the
4023
               --  etype of the referenced entity, then leave it alone. This
4024
               --  happens for trees generated from Exp_Pakd, where expressions
4025
               --  can be deliberately "mis-typed" to the packed array type.
4026
 
4027
               if Is_Array_Type (Entyp)
4028
                 and then Is_Packed (Entyp)
4029
                 and then Present (Etype (N))
4030
                 and then Etype (N) = Packed_Array_Type (Entyp)
4031
               then
4032
                  null;
4033
 
4034
               --  If not that special case, then just reset the Etype
4035
 
4036
               else
4037
                  Set_Etype (N, Etype (Entity (N)));
4038
               end if;
4039
            end;
4040
         end if;
4041
 
4042
         return;
4043
      end if;
4044
 
4045
      --  Here if Entity pointer was not set, we need full visibility analysis
4046
      --  First we generate debugging output if the debug E flag is set.
4047
 
4048
      if Debug_Flag_E then
4049
         Write_Str ("Looking for ");
4050
         Write_Name (Chars (N));
4051
         Write_Eol;
4052
      end if;
4053
 
4054
      Homonyms := Current_Entity (N);
4055
      Nvis_Entity := False;
4056
 
4057
      E := Homonyms;
4058
      while Present (E) loop
4059
 
4060
         --  If entity is immediately visible or potentially use visible, then
4061
         --  process the entity and we are done.
4062
 
4063
         if Is_Immediately_Visible (E) then
4064
            goto Immediately_Visible_Entity;
4065
 
4066
         elsif Is_Potentially_Use_Visible (E) then
4067
            goto Potentially_Use_Visible_Entity;
4068
 
4069
         --  Note if a known but invisible entity encountered
4070
 
4071
         elsif Known_But_Invisible (E) then
4072
            Nvis_Entity := True;
4073
         end if;
4074
 
4075
         --  Move to next entity in chain and continue search
4076
 
4077
         E := Homonym (E);
4078
      end loop;
4079
 
4080
      --  If no entries on homonym chain that were potentially visible,
4081
      --  and no entities reasonably considered as non-visible, then
4082
      --  we have a plain undefined reference, with no additional
4083
      --  explanation required!
4084
 
4085
      if not Nvis_Entity then
4086
         Undefined (Nvis => False);
4087
 
4088
      --  Otherwise there is at least one entry on the homonym chain that
4089
      --  is reasonably considered as being known and non-visible.
4090
 
4091
      else
4092
         Nvis_Messages;
4093
      end if;
4094
 
4095
      return;
4096
 
4097
      --  Processing for a potentially use visible entry found. We must search
4098
      --  the rest of the homonym chain for two reasons. First, if there is a
4099
      --  directly visible entry, then none of the potentially use-visible
4100
      --  entities are directly visible (RM 8.4(10)). Second, we need to check
4101
      --  for the case of multiple potentially use-visible entries hiding one
4102
      --  another and as a result being non-directly visible (RM 8.4(11)).
4103
 
4104
      <<Potentially_Use_Visible_Entity>> declare
4105
         Only_One_Visible : Boolean := True;
4106
         All_Overloadable : Boolean := Is_Overloadable (E);
4107
 
4108
      begin
4109
         E2 := Homonym (E);
4110
         while Present (E2) loop
4111
            if Is_Immediately_Visible (E2) then
4112
 
4113
               --  If the use-visible entity comes from the actual for a
4114
               --  formal package, it hides a directly visible entity from
4115
               --  outside the instance.
4116
 
4117
               if From_Actual_Package (E)
4118
                 and then Scope_Depth (E2) < Scope_Depth (Inst)
4119
               then
4120
                  goto Found;
4121
               else
4122
                  E := E2;
4123
                  goto Immediately_Visible_Entity;
4124
               end if;
4125
 
4126
            elsif Is_Potentially_Use_Visible (E2) then
4127
               Only_One_Visible := False;
4128
               All_Overloadable := All_Overloadable and Is_Overloadable (E2);
4129
 
4130
            --  Ada 2005 (AI-262): Protect against a form of Beaujolais effect
4131
            --  that can occur in private_with clauses. Example:
4132
 
4133
            --    with A;
4134
            --    private with B;              package A is
4135
            --    package C is                   function B return Integer;
4136
            --      use A;                     end A;
4137
            --      V1 : Integer := B;
4138
            --    private                      function B return Integer;
4139
            --      V2 : Integer := B;
4140
            --    end C;
4141
 
4142
            --  V1 resolves to A.B, but V2 resolves to library unit B
4143
 
4144
            elsif Ekind (E2) = E_Function
4145
              and then Scope (E2) = Standard_Standard
4146
              and then Has_Private_With (E2)
4147
            then
4148
               Only_One_Visible       := False;
4149
               All_Overloadable       := False;
4150
               Nvis_Is_Private_Subprg := True;
4151
               exit;
4152
            end if;
4153
 
4154
            E2 := Homonym (E2);
4155
         end loop;
4156
 
4157
         --  On falling through this loop, we have checked that there are no
4158
         --  immediately visible entities. Only_One_Visible is set if exactly
4159
         --  one potentially use visible entity exists. All_Overloadable is
4160
         --  set if all the potentially use visible entities are overloadable.
4161
         --  The condition for legality is that either there is one potentially
4162
         --  use visible entity, or if there is more than one, then all of them
4163
         --  are overloadable.
4164
 
4165
         if Only_One_Visible or All_Overloadable then
4166
            goto Found;
4167
 
4168
         --  If there is more than one potentially use-visible entity and at
4169
         --  least one of them non-overloadable, we have an error (RM 8.4(11).
4170
         --  Note that E points to the first such entity on the homonym list.
4171
         --  Special case: if one of the entities is declared in an actual
4172
         --  package, it was visible in the generic, and takes precedence over
4173
         --  other entities that are potentially use-visible. Same if it is
4174
         --  declared in a local instantiation of the current instance.
4175
 
4176
         else
4177
            if In_Instance then
4178
 
4179
               --  Find current instance
4180
 
4181
               Inst := Current_Scope;
4182
               while Present (Inst)
4183
                 and then Inst /= Standard_Standard
4184
               loop
4185
                  if Is_Generic_Instance (Inst) then
4186
                     exit;
4187
                  end if;
4188
 
4189
                  Inst := Scope (Inst);
4190
               end loop;
4191
 
4192
               E2 := E;
4193
               while Present (E2) loop
4194
                  if From_Actual_Package (E2)
4195
                    or else
4196
                      (Is_Generic_Instance (Scope (E2))
4197
                        and then Scope_Depth (Scope (E2)) > Scope_Depth (Inst))
4198
                  then
4199
                     E := E2;
4200
                     goto Found;
4201
                  end if;
4202
 
4203
                  E2 := Homonym (E2);
4204
               end loop;
4205
 
4206
               Nvis_Messages;
4207
               return;
4208
 
4209
            elsif
4210
              Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
4211
            then
4212
               --  A use-clause in the body of a system file creates conflict
4213
               --  with some entity in a user scope, while rtsfind is active.
4214
               --  Keep only the entity coming from another predefined unit.
4215
 
4216
               E2 := E;
4217
               while Present (E2) loop
4218
                  if Is_Predefined_File_Name
4219
                    (Unit_File_Name (Get_Source_Unit (Sloc (E2))))
4220
                  then
4221
                     E := E2;
4222
                     goto Found;
4223
                  end if;
4224
 
4225
                  E2 := Homonym (E2);
4226
               end loop;
4227
 
4228
               --  Entity must exist because predefined unit is correct
4229
 
4230
               raise Program_Error;
4231
 
4232
            else
4233
               Nvis_Messages;
4234
               return;
4235
            end if;
4236
         end if;
4237
      end;
4238
 
4239
      --  Come here with E set to the first immediately visible entity on
4240
      --  the homonym chain. This is the one we want unless there is another
4241
      --  immediately visible entity further on in the chain for an inner
4242
      --  scope (RM 8.3(8)).
4243
 
4244
      <<Immediately_Visible_Entity>> declare
4245
         Level : Int;
4246
         Scop  : Entity_Id;
4247
 
4248
      begin
4249
         --  Find scope level of initial entity. When compiling through
4250
         --  Rtsfind, the previous context is not completely invisible, and
4251
         --  an outer entity may appear on the chain, whose scope is below
4252
         --  the entry for Standard that delimits the current scope stack.
4253
         --  Indicate that the level for this spurious entry is outside of
4254
         --  the current scope stack.
4255
 
4256
         Level := Scope_Stack.Last;
4257
         loop
4258
            Scop := Scope_Stack.Table (Level).Entity;
4259
            exit when Scop = Scope (E);
4260
            Level := Level - 1;
4261
            exit when Scop = Standard_Standard;
4262
         end loop;
4263
 
4264
         --  Now search remainder of homonym chain for more inner entry
4265
         --  If the entity is Standard itself, it has no scope, and we
4266
         --  compare it with the stack entry directly.
4267
 
4268
         E2 := Homonym (E);
4269
         while Present (E2) loop
4270
            if Is_Immediately_Visible (E2) then
4271
 
4272
               --  If a generic package contains a local declaration that
4273
               --  has the same name as the generic, there may be a visibility
4274
               --  conflict in an instance, where the local declaration must
4275
               --  also hide the name of the corresponding package renaming.
4276
               --  We check explicitly for a package declared by a renaming,
4277
               --  whose renamed entity is an instance that is on the scope
4278
               --  stack, and that contains a homonym in the same scope. Once
4279
               --  we have found it, we know that the package renaming is not
4280
               --  immediately visible, and that the identifier denotes the
4281
               --  other entity (and its homonyms if overloaded).
4282
 
4283
               if Scope (E) = Scope (E2)
4284
                 and then Ekind (E) = E_Package
4285
                 and then Present (Renamed_Object (E))
4286
                 and then Is_Generic_Instance (Renamed_Object (E))
4287
                 and then In_Open_Scopes (Renamed_Object (E))
4288
                 and then Comes_From_Source (N)
4289
               then
4290
                  Set_Is_Immediately_Visible (E, False);
4291
                  E := E2;
4292
 
4293
               else
4294
                  for J in Level + 1 .. Scope_Stack.Last loop
4295
                     if Scope_Stack.Table (J).Entity = Scope (E2)
4296
                       or else Scope_Stack.Table (J).Entity = E2
4297
                     then
4298
                        Level := J;
4299
                        E := E2;
4300
                        exit;
4301
                     end if;
4302
                  end loop;
4303
               end if;
4304
            end if;
4305
 
4306
            E2 := Homonym (E2);
4307
         end loop;
4308
 
4309
         --  At the end of that loop, E is the innermost immediately
4310
         --  visible entity, so we are all set.
4311
      end;
4312
 
4313
      --  Come here with entity found, and stored in E
4314
 
4315
      <<Found>> begin
4316
 
4317
         --  When distribution features are available (Get_PCS_Name /=
4318
         --  Name_No_DSA), a remote access-to-subprogram type is converted
4319
         --  into a record type holding whatever information is needed to
4320
         --  perform a remote call on an RCI subprogram. In that case we
4321
         --  rewrite any occurrence of the RAS type into the equivalent record
4322
         --  type here. 'Access attribute references and RAS dereferences are
4323
         --  then implemented using specific TSSs. However when distribution is
4324
         --  not available (case of Get_PCS_Name = Name_No_DSA), we bypass the
4325
         --  generation of these TSSs, and we must keep the RAS type in its
4326
         --  original access-to-subprogram form (since all calls through a
4327
         --  value of such type will be local anyway in the absence of a PCS).
4328
 
4329
         if Comes_From_Source (N)
4330
           and then Is_Remote_Access_To_Subprogram_Type (E)
4331
           and then Expander_Active
4332
           and then Get_PCS_Name /= Name_No_DSA
4333
         then
4334
            Rewrite (N,
4335
              New_Occurrence_Of (Equivalent_Type (E), Sloc (N)));
4336
            return;
4337
         end if;
4338
 
4339
         Set_Entity (N, E);
4340
         --  Why no Style_Check here???
4341
 
4342
         if Is_Type (E) then
4343
            Set_Etype (N, E);
4344
         else
4345
            Set_Etype (N, Get_Full_View (Etype (E)));
4346
         end if;
4347
 
4348
         if Debug_Flag_E then
4349
            Write_Str (" found  ");
4350
            Write_Entity_Info (E, "      ");
4351
         end if;
4352
 
4353
         --  If the Ekind of the entity is Void, it means that all homonyms
4354
         --  are hidden from all visibility (RM 8.3(5,14-20)). However, this
4355
         --  test is skipped if the current scope is a record and the name is
4356
         --  a pragma argument expression (case of Atomic and Volatile pragmas
4357
         --  and possibly other similar pragmas added later, which are allowed
4358
         --  to reference components in the current record).
4359
 
4360
         if Ekind (E) = E_Void
4361
           and then
4362
             (not Is_Record_Type (Current_Scope)
4363
               or else Nkind (Parent (N)) /= N_Pragma_Argument_Association)
4364
         then
4365
            Premature_Usage (N);
4366
 
4367
         --  If the entity is overloadable, collect all interpretations of the
4368
         --  name for subsequent overload resolution. We optimize a bit here to
4369
         --  do this only if we have an overloadable entity that is not on its
4370
         --  own on the homonym chain.
4371
 
4372
         elsif Is_Overloadable (E)
4373
           and then (Present (Homonym (E)) or else Current_Entity (N) /= E)
4374
         then
4375
            Collect_Interps (N);
4376
 
4377
            --  If no homonyms were visible, the entity is unambiguous
4378
 
4379
            if not Is_Overloaded (N) then
4380
               if not Is_Actual_Parameter then
4381
                  Generate_Reference (E, N);
4382
               end if;
4383
            end if;
4384
 
4385
         --  Case of non-overloadable entity, set the entity providing that
4386
         --  we do not have the case of a discriminant reference within a
4387
         --  default expression. Such references are replaced with the
4388
         --  corresponding discriminal, which is the formal corresponding to
4389
         --  to the discriminant in the initialization procedure.
4390
 
4391
         else
4392
            --  Entity is unambiguous, indicate that it is referenced here
4393
 
4394
            --  For a renaming of an object, always generate simple reference,
4395
            --  we don't try to keep track of assignments in this case.
4396
 
4397
            if Is_Object (E) and then Present (Renamed_Object (E)) then
4398
               Generate_Reference (E, N);
4399
 
4400
               --  If the renamed entity is a private protected component,
4401
               --  reference the original component as well. This needs to be
4402
               --  done because the private renamings are installed before any
4403
               --  analysis has occurred. Reference to a private component will
4404
               --  resolve to the renaming and the original component will be
4405
               --  left unreferenced, hence the following.
4406
 
4407
               if Is_Prival (E) then
4408
                  Generate_Reference (Prival_Link (E), N);
4409
               end if;
4410
 
4411
            --  One odd case is that we do not want to set the Referenced flag
4412
            --  if the entity is a label, and the identifier is the label in
4413
            --  the source, since this is not a reference from the point of
4414
            --  view of the user.
4415
 
4416
            elsif Nkind (Parent (N)) = N_Label then
4417
               declare
4418
                  R : constant Boolean := Referenced (E);
4419
 
4420
               begin
4421
                  --  Generate reference unless this is an actual parameter
4422
                  --  (see comment below)
4423
 
4424
                  if Is_Actual_Parameter then
4425
                     Generate_Reference (E, N);
4426
                     Set_Referenced (E, R);
4427
                  end if;
4428
               end;
4429
 
4430
            --  Normal case, not a label: generate reference
4431
 
4432
            --  ??? It is too early to generate a reference here even if
4433
            --    the entity is unambiguous, because the tree is not
4434
            --    sufficiently typed at this point for Generate_Reference to
4435
            --    determine whether this reference modifies the denoted object
4436
            --    (because implicit dereferences cannot be identified prior to
4437
            --    full type resolution).
4438
            --
4439
            --    The Is_Actual_Parameter routine takes care of one of these
4440
            --    cases but there are others probably ???
4441
 
4442
            else
4443
               if not Is_Actual_Parameter then
4444
                  Generate_Reference (E, N);
4445
               end if;
4446
 
4447
               Check_Nested_Access (E);
4448
            end if;
4449
 
4450
            --  Set Entity, with style check if need be. For a discriminant
4451
            --  reference, replace by the corresponding discriminal, i.e. the
4452
            --  parameter of the initialization procedure that corresponds to
4453
            --  the discriminant. If this replacement is being performed, there
4454
            --  is no style check to perform.
4455
 
4456
            --  This replacement must not be done if we are currently
4457
            --  processing a generic spec or body, because the discriminal
4458
            --  has not been not generated in this case.
4459
 
4460
            --  The replacement is also skipped if we are in special
4461
            --  spec-expression mode. Why is this skipped in this case ???
4462
 
4463
            if not In_Spec_Expression
4464
              or else Ekind (E) /= E_Discriminant
4465
              or else Inside_A_Generic
4466
            then
4467
               Set_Entity_With_Style_Check (N, E);
4468
 
4469
            --  The replacement is not done either for a task discriminant that
4470
            --  appears in a default expression of an entry parameter. See
4471
            --  Expand_Discriminant in exp_ch2 for details on their handling.
4472
 
4473
            elsif Is_Concurrent_Type (Scope (E)) then
4474
               declare
4475
                  P : Node_Id;
4476
 
4477
               begin
4478
                  P := Parent (N);
4479
                  while Present (P)
4480
                    and then not Nkind_In (P, N_Parameter_Specification,
4481
                                              N_Component_Declaration)
4482
                  loop
4483
                     P := Parent (P);
4484
                  end loop;
4485
 
4486
                  if Present (P)
4487
                     and then Nkind (P) = N_Parameter_Specification
4488
                  then
4489
                     null;
4490
                  else
4491
                     Set_Entity (N, Discriminal (E));
4492
                  end if;
4493
               end;
4494
 
4495
            --  Otherwise, this is a discriminant in a context in which
4496
            --  it is a reference to the corresponding parameter of the
4497
            --  init proc for the enclosing type.
4498
 
4499
            else
4500
               Set_Entity (N, Discriminal (E));
4501
            end if;
4502
         end if;
4503
      end;
4504
   end Find_Direct_Name;
4505
 
4506
   ------------------------
4507
   -- Find_Expanded_Name --
4508
   ------------------------
4509
 
4510
   --  This routine searches the homonym chain of the entity until it finds
4511
   --  an entity declared in the scope denoted by the prefix. If the entity
4512
   --  is private, it may nevertheless be immediately visible, if we are in
4513
   --  the scope of its declaration.
4514
 
4515
   procedure Find_Expanded_Name (N : Node_Id) is
4516
      Selector  : constant Node_Id := Selector_Name (N);
4517
      Candidate : Entity_Id        := Empty;
4518
      P_Name    : Entity_Id;
4519
      O_Name    : Entity_Id;
4520
      Id        : Entity_Id;
4521
 
4522
   begin
4523
      P_Name := Entity (Prefix (N));
4524
      O_Name := P_Name;
4525
 
4526
      --  If the prefix is a renamed package, look for the entity in the
4527
      --  original package.
4528
 
4529
      if Ekind (P_Name) = E_Package
4530
        and then Present (Renamed_Object (P_Name))
4531
      then
4532
         P_Name := Renamed_Object (P_Name);
4533
 
4534
         --  Rewrite node with entity field pointing to renamed object
4535
 
4536
         Rewrite (Prefix (N), New_Copy (Prefix (N)));
4537
         Set_Entity (Prefix (N), P_Name);
4538
 
4539
      --  If the prefix is an object of a concurrent type, look for
4540
      --  the entity in the associated task or protected type.
4541
 
4542
      elsif Is_Concurrent_Type (Etype (P_Name)) then
4543
         P_Name := Etype (P_Name);
4544
      end if;
4545
 
4546
      Id := Current_Entity (Selector);
4547
 
4548
      declare
4549
         Is_New_Candidate : Boolean;
4550
 
4551
      begin
4552
         while Present (Id) loop
4553
            if Scope (Id) = P_Name then
4554
               Candidate        := Id;
4555
               Is_New_Candidate := True;
4556
 
4557
            --  Ada 2005 (AI-217): Handle shadow entities associated with types
4558
            --  declared in limited-withed nested packages. We don't need to
4559
            --  handle E_Incomplete_Subtype entities because the entities in
4560
            --  the limited view are always E_Incomplete_Type entities (see
4561
            --  Build_Limited_Views). Regarding the expression used to evaluate
4562
            --  the scope, it is important to note that the limited view also
4563
            --  has shadow entities associated nested packages. For this reason
4564
            --  the correct scope of the entity is the scope of the real entity
4565
            --  The non-limited view may itself be incomplete, in which case
4566
            --  get the full view if available.
4567
 
4568
            elsif From_With_Type (Id)
4569
              and then Is_Type (Id)
4570
              and then Ekind (Id) = E_Incomplete_Type
4571
              and then Present (Non_Limited_View (Id))
4572
              and then Scope (Non_Limited_View (Id)) = P_Name
4573
            then
4574
               Candidate        := Get_Full_View (Non_Limited_View (Id));
4575
               Is_New_Candidate := True;
4576
 
4577
            else
4578
               Is_New_Candidate := False;
4579
            end if;
4580
 
4581
            if Is_New_Candidate then
4582
               if Is_Child_Unit (Id) then
4583
                  exit when Is_Visible_Child_Unit (Id)
4584
                    or else Is_Immediately_Visible (Id);
4585
 
4586
               else
4587
                  exit when not Is_Hidden (Id)
4588
                    or else Is_Immediately_Visible (Id);
4589
               end if;
4590
            end if;
4591
 
4592
            Id := Homonym (Id);
4593
         end loop;
4594
      end;
4595
 
4596
      if No (Id)
4597
        and then (Ekind (P_Name) = E_Procedure
4598
                    or else
4599
                  Ekind (P_Name) = E_Function)
4600
        and then Is_Generic_Instance (P_Name)
4601
      then
4602
         --  Expanded name denotes entity in (instance of) generic subprogram.
4603
         --  The entity may be in the subprogram instance, or may denote one of
4604
         --  the formals, which is declared in the enclosing wrapper package.
4605
 
4606
         P_Name := Scope (P_Name);
4607
 
4608
         Id := Current_Entity (Selector);
4609
         while Present (Id) loop
4610
            exit when Scope (Id) = P_Name;
4611
            Id := Homonym (Id);
4612
         end loop;
4613
      end if;
4614
 
4615
      if No (Id) or else Chars (Id) /= Chars (Selector) then
4616
         Set_Etype (N, Any_Type);
4617
 
4618
         --  If we are looking for an entity defined in System, try to find it
4619
         --  in the child package that may have been provided as an extension
4620
         --  to System. The Extend_System pragma will have supplied the name of
4621
         --  the extension, which may have to be loaded.
4622
 
4623
         if Chars (P_Name) = Name_System
4624
           and then Scope (P_Name) = Standard_Standard
4625
           and then Present (System_Extend_Unit)
4626
           and then Present_System_Aux (N)
4627
         then
4628
            Set_Entity (Prefix (N), System_Aux_Id);
4629
            Find_Expanded_Name (N);
4630
            return;
4631
 
4632
         elsif Nkind (Selector) = N_Operator_Symbol
4633
           and then Has_Implicit_Operator (N)
4634
         then
4635
            --  There is an implicit instance of the predefined operator in
4636
            --  the given scope. The operator entity is defined in Standard.
4637
            --  Has_Implicit_Operator makes the node into an Expanded_Name.
4638
 
4639
            return;
4640
 
4641
         elsif Nkind (Selector) = N_Character_Literal
4642
           and then Has_Implicit_Character_Literal (N)
4643
         then
4644
            --  If there is no literal defined in the scope denoted by the
4645
            --  prefix, the literal may belong to (a type derived from)
4646
            --  Standard_Character, for which we have no explicit literals.
4647
 
4648
            return;
4649
 
4650
         else
4651
            --  If the prefix is a single concurrent object, use its name in
4652
            --  the error message, rather than that of the anonymous type.
4653
 
4654
            if Is_Concurrent_Type (P_Name)
4655
              and then Is_Internal_Name (Chars (P_Name))
4656
            then
4657
               Error_Msg_Node_2 := Entity (Prefix (N));
4658
            else
4659
               Error_Msg_Node_2 := P_Name;
4660
            end if;
4661
 
4662
            if P_Name = System_Aux_Id then
4663
               P_Name := Scope (P_Name);
4664
               Set_Entity (Prefix (N), P_Name);
4665
            end if;
4666
 
4667
            if Present (Candidate) then
4668
 
4669
               --  If we know that the unit is a child unit we can give a more
4670
               --  accurate error message.
4671
 
4672
               if Is_Child_Unit (Candidate) then
4673
 
4674
                  --  If the candidate is a private child unit and we are in
4675
                  --  the visible part of a public unit, specialize the error
4676
                  --  message. There might be a private with_clause for it,
4677
                  --  but it is not currently active.
4678
 
4679
                  if Is_Private_Descendant (Candidate)
4680
                    and then Ekind (Current_Scope) = E_Package
4681
                    and then not In_Private_Part (Current_Scope)
4682
                    and then not Is_Private_Descendant (Current_Scope)
4683
                  then
4684
                     Error_Msg_N ("private child unit& is not visible here",
4685
                                  Selector);
4686
 
4687
                  --  Normal case where we have a missing with for a child unit
4688
 
4689
                  else
4690
                     Error_Msg_Qual_Level := 99;
4691
                     Error_Msg_NE ("missing `WITH &;`", Selector, Candidate);
4692
                     Error_Msg_Qual_Level := 0;
4693
                  end if;
4694
 
4695
                  --  Here we don't know that this is a child unit
4696
 
4697
               else
4698
                  Error_Msg_NE ("& is not a visible entity of&", N, Selector);
4699
               end if;
4700
 
4701
            else
4702
               --  Within the instantiation of a child unit, the prefix may
4703
               --  denote the parent instance, but the selector has the name
4704
               --  of the original child. Find whether we are within the
4705
               --  corresponding instance, and get the proper entity, which
4706
               --  can only be an enclosing scope.
4707
 
4708
               if O_Name /= P_Name
4709
                 and then In_Open_Scopes (P_Name)
4710
                 and then Is_Generic_Instance (P_Name)
4711
               then
4712
                  declare
4713
                     S : Entity_Id := Current_Scope;
4714
                     P : Entity_Id;
4715
 
4716
                  begin
4717
                     for J in reverse 0 .. Scope_Stack.Last loop
4718
                        S := Scope_Stack.Table (J).Entity;
4719
 
4720
                        exit when S = Standard_Standard;
4721
 
4722
                        if Ekind (S) = E_Function
4723
                          or else Ekind (S) = E_Package
4724
                          or else Ekind (S) = E_Procedure
4725
                        then
4726
                           P := Generic_Parent (Specification
4727
                                  (Unit_Declaration_Node (S)));
4728
 
4729
                           if Present (P)
4730
                             and then Chars (Scope (P)) = Chars (O_Name)
4731
                             and then Chars (P) = Chars (Selector)
4732
                           then
4733
                              Id := S;
4734
                              goto Found;
4735
                           end if;
4736
                        end if;
4737
 
4738
                     end loop;
4739
                  end;
4740
               end if;
4741
 
4742
               --  If this is a selection from Ada, System or Interfaces, then
4743
               --  we assume a missing with for the corresponding package.
4744
 
4745
               if Is_Known_Unit (N) then
4746
                  if not Error_Posted (N) then
4747
                     Error_Msg_Node_2 := Selector;
4748
                     Error_Msg_N ("missing `WITH &.&;`", Prefix (N));
4749
                  end if;
4750
 
4751
               --  If this is a selection from a dummy package, then suppress
4752
               --  the error message, of course the entity is missing if the
4753
               --  package is missing!
4754
 
4755
               elsif Sloc (Error_Msg_Node_2) = No_Location then
4756
                  null;
4757
 
4758
               --  Here we have the case of an undefined component
4759
 
4760
               else
4761
 
4762
                  --  The prefix may hide a homonym in the context that
4763
                  --  declares the desired entity. This error can use a
4764
                  --  specialized message.
4765
 
4766
                  if In_Open_Scopes (P_Name)
4767
                    and then Present (Homonym (P_Name))
4768
                    and then Is_Compilation_Unit (Homonym (P_Name))
4769
                    and then
4770
                     (Is_Immediately_Visible (Homonym (P_Name))
4771
                        or else Is_Visible_Child_Unit (Homonym (P_Name)))
4772
                  then
4773
                     declare
4774
                        H : constant Entity_Id := Homonym (P_Name);
4775
 
4776
                     begin
4777
                        Id := First_Entity (H);
4778
                        while Present (Id) loop
4779
                           if Chars (Id) = Chars (Selector) then
4780
                              Error_Msg_Qual_Level := 99;
4781
                              Error_Msg_Name_1 := Chars (Selector);
4782
                              Error_Msg_NE
4783
                                ("% not declared in&", N, P_Name);
4784
                              Error_Msg_NE
4785
                                ("\use fully qualified name starting with"
4786
                                  & " Standard to make& visible", N, H);
4787
                              Error_Msg_Qual_Level := 0;
4788
                              exit;
4789
                           end if;
4790
 
4791
                           Next_Entity (Id);
4792
                        end loop;
4793
                     end;
4794
 
4795
                  else
4796
                     Error_Msg_NE ("& not declared in&", N, Selector);
4797
                  end if;
4798
 
4799
                  --  Check for misspelling of some entity in prefix
4800
 
4801
                  Id := First_Entity (P_Name);
4802
                  while Present (Id) loop
4803
                     if Is_Bad_Spelling_Of (Chars (Id), Chars (Selector))
4804
                       and then not Is_Internal_Name (Chars (Id))
4805
                     then
4806
                        Error_Msg_NE -- CODEFIX
4807
                          ("possible misspelling of&", Selector, Id);
4808
                        exit;
4809
                     end if;
4810
 
4811
                     Next_Entity (Id);
4812
                  end loop;
4813
 
4814
                  --  Specialize the message if this may be an instantiation
4815
                  --  of a child unit that was not mentioned in the context.
4816
 
4817
                  if Nkind (Parent (N)) = N_Package_Instantiation
4818
                    and then Is_Generic_Instance (Entity (Prefix (N)))
4819
                    and then Is_Compilation_Unit
4820
                               (Generic_Parent (Parent (Entity (Prefix (N)))))
4821
                  then
4822
                     Error_Msg_Node_2 := Selector;
4823
                     Error_Msg_N ("\missing `WITH &.&;`", Prefix (N));
4824
                  end if;
4825
               end if;
4826
            end if;
4827
 
4828
            Id := Any_Id;
4829
         end if;
4830
      end if;
4831
 
4832
      <<Found>>
4833
      if Comes_From_Source (N)
4834
        and then Is_Remote_Access_To_Subprogram_Type (Id)
4835
        and then Present (Equivalent_Type (Id))
4836
      then
4837
         --  If we are not actually generating distribution code (i.e. the
4838
         --  current PCS is the dummy non-distributed version), then the
4839
         --  Equivalent_Type will be missing, and Id should be treated as
4840
         --  a regular access-to-subprogram type.
4841
 
4842
         Id := Equivalent_Type (Id);
4843
         Set_Chars (Selector, Chars (Id));
4844
      end if;
4845
 
4846
      --  Ada 2005 (AI-50217): Check usage of entities in limited withed units
4847
 
4848
      if Ekind (P_Name) = E_Package
4849
        and then From_With_Type (P_Name)
4850
      then
4851
         if From_With_Type (Id)
4852
           or else Is_Type (Id)
4853
           or else Ekind (Id) = E_Package
4854
         then
4855
            null;
4856
         else
4857
            Error_Msg_N
4858
              ("limited withed package can only be used to access "
4859
               & "incomplete types",
4860
                N);
4861
         end if;
4862
      end if;
4863
 
4864
      if Is_Task_Type (P_Name)
4865
        and then ((Ekind (Id) = E_Entry
4866
                     and then Nkind (Parent (N)) /= N_Attribute_Reference)
4867
                   or else
4868
                    (Ekind (Id) = E_Entry_Family
4869
                      and then
4870
                        Nkind (Parent (Parent (N))) /= N_Attribute_Reference))
4871
      then
4872
         --  It is an entry call after all, either to the current task (which
4873
         --  will deadlock) or to an enclosing task.
4874
 
4875
         Analyze_Selected_Component (N);
4876
         return;
4877
      end if;
4878
 
4879
      Change_Selected_Component_To_Expanded_Name (N);
4880
 
4881
      --  Do style check and generate reference, but skip both steps if this
4882
      --  entity has homonyms, since we may not have the right homonym set yet.
4883
      --  The proper homonym will be set during the resolve phase.
4884
 
4885
      if Has_Homonym (Id) then
4886
         Set_Entity (N, Id);
4887
      else
4888
         Set_Entity_With_Style_Check (N, Id);
4889
         Generate_Reference (Id, N);
4890
      end if;
4891
 
4892
      if Is_Type (Id) then
4893
         Set_Etype (N, Id);
4894
      else
4895
         Set_Etype (N, Get_Full_View (Etype (Id)));
4896
      end if;
4897
 
4898
      --  If the Ekind of the entity is Void, it means that all homonyms are
4899
      --  hidden from all visibility (RM 8.3(5,14-20)).
4900
 
4901
      if Ekind (Id) = E_Void then
4902
         Premature_Usage (N);
4903
 
4904
      elsif Is_Overloadable (Id)
4905
        and then Present (Homonym (Id))
4906
      then
4907
         declare
4908
            H : Entity_Id := Homonym (Id);
4909
 
4910
         begin
4911
            while Present (H) loop
4912
               if Scope (H) = Scope (Id)
4913
                 and then
4914
                   (not Is_Hidden (H)
4915
                      or else Is_Immediately_Visible (H))
4916
               then
4917
                  Collect_Interps (N);
4918
                  exit;
4919
               end if;
4920
 
4921
               H := Homonym (H);
4922
            end loop;
4923
 
4924
            --  If an extension of System is present, collect possible explicit
4925
            --  overloadings declared in the extension.
4926
 
4927
            if Chars (P_Name) = Name_System
4928
              and then Scope (P_Name) = Standard_Standard
4929
              and then Present (System_Extend_Unit)
4930
              and then Present_System_Aux (N)
4931
            then
4932
               H := Current_Entity (Id);
4933
 
4934
               while Present (H) loop
4935
                  if Scope (H) = System_Aux_Id then
4936
                     Add_One_Interp (N, H, Etype (H));
4937
                  end if;
4938
 
4939
                  H := Homonym (H);
4940
               end loop;
4941
            end if;
4942
         end;
4943
      end if;
4944
 
4945
      if Nkind (Selector_Name (N)) = N_Operator_Symbol
4946
        and then Scope (Id) /= Standard_Standard
4947
      then
4948
         --  In addition to user-defined operators in the given scope, there
4949
         --  may be an implicit instance of the predefined operator. The
4950
         --  operator (defined in Standard) is found in Has_Implicit_Operator,
4951
         --  and added to the interpretations. Procedure Add_One_Interp will
4952
         --  determine which hides which.
4953
 
4954
         if Has_Implicit_Operator (N) then
4955
            null;
4956
         end if;
4957
      end if;
4958
   end Find_Expanded_Name;
4959
 
4960
   -------------------------
4961
   -- Find_Renamed_Entity --
4962
   -------------------------
4963
 
4964
   function Find_Renamed_Entity
4965
     (N         : Node_Id;
4966
      Nam       : Node_Id;
4967
      New_S     : Entity_Id;
4968
      Is_Actual : Boolean := False) return Entity_Id
4969
   is
4970
      Ind   : Interp_Index;
4971
      I1    : Interp_Index := 0; -- Suppress junk warnings
4972
      It    : Interp;
4973
      It1   : Interp;
4974
      Old_S : Entity_Id;
4975
      Inst  : Entity_Id;
4976
 
4977
      function Enclosing_Instance return Entity_Id;
4978
      --  If the renaming determines the entity for the default of a formal
4979
      --  subprogram nested within another instance, choose the innermost
4980
      --  candidate. This is because if the formal has a box, and we are within
4981
      --  an enclosing instance where some candidate interpretations are local
4982
      --  to this enclosing instance, we know that the default was properly
4983
      --  resolved when analyzing the generic, so we prefer the local
4984
      --  candidates to those that are external. This is not always the case
4985
      --  but is a reasonable heuristic on the use of nested generics. The
4986
      --  proper solution requires a full renaming model.
4987
 
4988
      function Is_Visible_Operation (Op : Entity_Id) return Boolean;
4989
      --  If the renamed entity is an implicit operator, check whether it is
4990
      --  visible because its operand type is properly visible. This check
4991
      --  applies to explicit renamed entities that appear in the source in a
4992
      --  renaming declaration or a formal subprogram instance, but not to
4993
      --  default generic actuals with a name.
4994
 
4995
      function Report_Overload return Entity_Id;
4996
      --  List possible interpretations, and specialize message in the
4997
      --  case of a generic actual.
4998
 
4999
      function Within (Inner, Outer : Entity_Id) return Boolean;
5000
      --  Determine whether a candidate subprogram is defined within the
5001
      --  enclosing instance. If yes, it has precedence over outer candidates.
5002
 
5003
      ------------------------
5004
      -- Enclosing_Instance --
5005
      ------------------------
5006
 
5007
      function Enclosing_Instance return Entity_Id is
5008
         S : Entity_Id;
5009
 
5010
      begin
5011
         if not Is_Generic_Instance (Current_Scope)
5012
           and then not Is_Actual
5013
         then
5014
            return Empty;
5015
         end if;
5016
 
5017
         S := Scope (Current_Scope);
5018
         while S /= Standard_Standard loop
5019
            if Is_Generic_Instance (S) then
5020
               return S;
5021
            end if;
5022
 
5023
            S := Scope (S);
5024
         end loop;
5025
 
5026
         return Empty;
5027
      end Enclosing_Instance;
5028
 
5029
      --------------------------
5030
      -- Is_Visible_Operation --
5031
      --------------------------
5032
 
5033
      function Is_Visible_Operation (Op : Entity_Id) return Boolean is
5034
         Scop : Entity_Id;
5035
         Typ  : Entity_Id;
5036
         Btyp : Entity_Id;
5037
 
5038
      begin
5039
         if Ekind (Op) /= E_Operator
5040
           or else Scope (Op) /= Standard_Standard
5041
           or else (In_Instance
5042
                      and then
5043
                        (not Is_Actual
5044
                           or else Present (Enclosing_Instance)))
5045
         then
5046
            return True;
5047
 
5048
         else
5049
            --  For a fixed point type operator, check the resulting type,
5050
            --  because it may be a mixed mode integer * fixed operation.
5051
 
5052
            if Present (Next_Formal (First_Formal (New_S)))
5053
              and then Is_Fixed_Point_Type (Etype (New_S))
5054
            then
5055
               Typ := Etype (New_S);
5056
            else
5057
               Typ := Etype (First_Formal (New_S));
5058
            end if;
5059
 
5060
            Btyp := Base_Type (Typ);
5061
 
5062
            if Nkind (Nam) /= N_Expanded_Name then
5063
               return (In_Open_Scopes (Scope (Btyp))
5064
                        or else Is_Potentially_Use_Visible (Btyp)
5065
                        or else In_Use (Btyp)
5066
                        or else In_Use (Scope (Btyp)));
5067
 
5068
            else
5069
               Scop := Entity (Prefix (Nam));
5070
 
5071
               if Ekind (Scop) = E_Package
5072
                 and then Present (Renamed_Object (Scop))
5073
               then
5074
                  Scop := Renamed_Object (Scop);
5075
               end if;
5076
 
5077
               --  Operator is visible if prefix of expanded name denotes
5078
               --  scope of type, or else type is defined in System_Aux
5079
               --  and the prefix denotes System.
5080
 
5081
               return Scope (Btyp) = Scop
5082
                 or else (Scope (Btyp) = System_Aux_Id
5083
                           and then Scope (Scope (Btyp)) = Scop);
5084
            end if;
5085
         end if;
5086
      end Is_Visible_Operation;
5087
 
5088
      ------------
5089
      -- Within --
5090
      ------------
5091
 
5092
      function Within (Inner, Outer : Entity_Id) return Boolean is
5093
         Sc : Entity_Id;
5094
 
5095
      begin
5096
         Sc := Scope (Inner);
5097
         while Sc /= Standard_Standard loop
5098
            if Sc = Outer then
5099
               return True;
5100
            else
5101
               Sc := Scope (Sc);
5102
            end if;
5103
         end loop;
5104
 
5105
         return False;
5106
      end Within;
5107
 
5108
      ---------------------
5109
      -- Report_Overload --
5110
      ---------------------
5111
 
5112
      function Report_Overload return Entity_Id is
5113
      begin
5114
         if Is_Actual then
5115
            Error_Msg_NE
5116
              ("ambiguous actual subprogram&, " &
5117
                 "possible interpretations:", N, Nam);
5118
         else
5119
            Error_Msg_N
5120
              ("ambiguous subprogram, " &
5121
                 "possible interpretations:", N);
5122
         end if;
5123
 
5124
         List_Interps (Nam, N);
5125
         return Old_S;
5126
      end Report_Overload;
5127
 
5128
   --  Start of processing for Find_Renamed_Entry
5129
 
5130
   begin
5131
      Old_S := Any_Id;
5132
      Candidate_Renaming := Empty;
5133
 
5134
      if not Is_Overloaded (Nam) then
5135
         if Entity_Matches_Spec (Entity (Nam), New_S) then
5136
            Candidate_Renaming := New_S;
5137
 
5138
            if Is_Visible_Operation (Entity (Nam)) then
5139
               Old_S := Entity (Nam);
5140
            end if;
5141
 
5142
         elsif
5143
           Present (First_Formal (Entity (Nam)))
5144
             and then Present (First_Formal (New_S))
5145
             and then (Base_Type (Etype (First_Formal (Entity (Nam))))
5146
                        = Base_Type (Etype (First_Formal (New_S))))
5147
         then
5148
            Candidate_Renaming := Entity (Nam);
5149
         end if;
5150
 
5151
      else
5152
         Get_First_Interp (Nam, Ind, It);
5153
         while Present (It.Nam) loop
5154
            if Entity_Matches_Spec (It.Nam, New_S)
5155
               and then Is_Visible_Operation (It.Nam)
5156
            then
5157
               if Old_S /= Any_Id then
5158
 
5159
                  --  Note: The call to Disambiguate only happens if a
5160
                  --  previous interpretation was found, in which case I1
5161
                  --  has received a value.
5162
 
5163
                  It1 := Disambiguate (Nam, I1, Ind, Etype (Old_S));
5164
 
5165
                  if It1 = No_Interp then
5166
                     Inst := Enclosing_Instance;
5167
 
5168
                     if Present (Inst) then
5169
                        if Within (It.Nam, Inst) then
5170
                           return (It.Nam);
5171
                        elsif Within (Old_S, Inst) then
5172
                           return (Old_S);
5173
                        else
5174
                           return Report_Overload;
5175
                        end if;
5176
 
5177
                     else
5178
                        return Report_Overload;
5179
                     end if;
5180
 
5181
                  else
5182
                     Old_S := It1.Nam;
5183
                     exit;
5184
                  end if;
5185
 
5186
               else
5187
                  I1 := Ind;
5188
                  Old_S := It.Nam;
5189
               end if;
5190
 
5191
            elsif
5192
              Present (First_Formal (It.Nam))
5193
                and then Present (First_Formal (New_S))
5194
                and then  (Base_Type (Etype (First_Formal (It.Nam)))
5195
                            = Base_Type (Etype (First_Formal (New_S))))
5196
            then
5197
               Candidate_Renaming := It.Nam;
5198
            end if;
5199
 
5200
            Get_Next_Interp (Ind, It);
5201
         end loop;
5202
 
5203
         Set_Entity (Nam, Old_S);
5204
         Set_Is_Overloaded (Nam, False);
5205
      end if;
5206
 
5207
      return Old_S;
5208
   end Find_Renamed_Entity;
5209
 
5210
   -----------------------------
5211
   -- Find_Selected_Component --
5212
   -----------------------------
5213
 
5214
   procedure Find_Selected_Component (N : Node_Id) is
5215
      P : constant Node_Id := Prefix (N);
5216
 
5217
      P_Name : Entity_Id;
5218
      --  Entity denoted by prefix
5219
 
5220
      P_Type : Entity_Id;
5221
      --  and its type
5222
 
5223
      Nam : Node_Id;
5224
 
5225
   begin
5226
      Analyze (P);
5227
 
5228
      if Nkind (P) = N_Error then
5229
         return;
5230
 
5231
      --  If the selector already has an entity, the node has been constructed
5232
      --  in the course of expansion, and is known to be valid. Do not verify
5233
      --  that it is defined for the type (it may be a private component used
5234
      --  in the expansion of record equality).
5235
 
5236
      elsif Present (Entity (Selector_Name (N))) then
5237
         if No (Etype (N))
5238
           or else Etype (N) = Any_Type
5239
         then
5240
            declare
5241
               Sel_Name : constant Node_Id   := Selector_Name (N);
5242
               Selector : constant Entity_Id := Entity (Sel_Name);
5243
               C_Etype  : Node_Id;
5244
 
5245
            begin
5246
               Set_Etype (Sel_Name, Etype (Selector));
5247
 
5248
               if not Is_Entity_Name (P) then
5249
                  Resolve (P);
5250
               end if;
5251
 
5252
               --  Build an actual subtype except for the first parameter
5253
               --  of an init proc, where this actual subtype is by
5254
               --  definition incorrect, since the object is uninitialized
5255
               --  (and does not even have defined discriminants etc.)
5256
 
5257
               if Is_Entity_Name (P)
5258
                 and then Ekind (Entity (P)) = E_Function
5259
               then
5260
                  Nam := New_Copy (P);
5261
 
5262
                  if Is_Overloaded (P) then
5263
                     Save_Interps (P, Nam);
5264
                  end if;
5265
 
5266
                  Rewrite (P,
5267
                    Make_Function_Call (Sloc (P), Name => Nam));
5268
                  Analyze_Call (P);
5269
                  Analyze_Selected_Component (N);
5270
                  return;
5271
 
5272
               elsif Ekind (Selector) = E_Component
5273
                 and then (not Is_Entity_Name (P)
5274
                            or else Chars (Entity (P)) /= Name_uInit)
5275
               then
5276
                  C_Etype :=
5277
                    Build_Actual_Subtype_Of_Component (
5278
                      Etype (Selector), N);
5279
               else
5280
                  C_Etype := Empty;
5281
               end if;
5282
 
5283
               if No (C_Etype) then
5284
                  C_Etype := Etype (Selector);
5285
               else
5286
                  Insert_Action (N, C_Etype);
5287
                  C_Etype := Defining_Identifier (C_Etype);
5288
               end if;
5289
 
5290
               Set_Etype (N, C_Etype);
5291
            end;
5292
 
5293
            --  If this is the name of an entry or protected operation, and
5294
            --  the prefix is an access type, insert an explicit dereference,
5295
            --  so that entry calls are treated uniformly.
5296
 
5297
            if Is_Access_Type (Etype (P))
5298
              and then Is_Concurrent_Type (Designated_Type (Etype (P)))
5299
            then
5300
               declare
5301
                  New_P : constant Node_Id :=
5302
                            Make_Explicit_Dereference (Sloc (P),
5303
                              Prefix => Relocate_Node (P));
5304
               begin
5305
                  Rewrite (P, New_P);
5306
                  Set_Etype (P, Designated_Type (Etype (Prefix (P))));
5307
               end;
5308
            end if;
5309
 
5310
         --  If the selected component appears within a default expression
5311
         --  and it has an actual subtype, the pre-analysis has not yet
5312
         --  completed its analysis, because Insert_Actions is disabled in
5313
         --  that context. Within the init proc of the enclosing type we
5314
         --  must complete this analysis, if an actual subtype was created.
5315
 
5316
         elsif Inside_Init_Proc then
5317
            declare
5318
               Typ  : constant Entity_Id := Etype (N);
5319
               Decl : constant Node_Id   := Declaration_Node (Typ);
5320
            begin
5321
               if Nkind (Decl) = N_Subtype_Declaration
5322
                 and then not Analyzed (Decl)
5323
                 and then Is_List_Member (Decl)
5324
                 and then No (Parent (Decl))
5325
               then
5326
                  Remove (Decl);
5327
                  Insert_Action (N, Decl);
5328
               end if;
5329
            end;
5330
         end if;
5331
 
5332
         return;
5333
 
5334
      elsif Is_Entity_Name (P) then
5335
         P_Name := Entity (P);
5336
 
5337
         --  The prefix may denote an enclosing type which is the completion
5338
         --  of an incomplete type declaration.
5339
 
5340
         if Is_Type (P_Name) then
5341
            Set_Entity (P, Get_Full_View (P_Name));
5342
            Set_Etype  (P, Entity (P));
5343
            P_Name := Entity (P);
5344
         end if;
5345
 
5346
         P_Type := Base_Type (Etype (P));
5347
 
5348
         if Debug_Flag_E then
5349
            Write_Str ("Found prefix type to be ");
5350
            Write_Entity_Info (P_Type, "      "); Write_Eol;
5351
         end if;
5352
 
5353
         --  First check for components of a record object (not the
5354
         --  result of a call, which is handled below).
5355
 
5356
         if Is_Appropriate_For_Record (P_Type)
5357
           and then not Is_Overloadable (P_Name)
5358
           and then not Is_Type (P_Name)
5359
         then
5360
            --  Selected component of record. Type checking will validate
5361
            --  name of selector.
5362
            --  ??? could we rewrite an implicit dereference into an explicit
5363
            --  one here?
5364
 
5365
            Analyze_Selected_Component (N);
5366
 
5367
         elsif Is_Appropriate_For_Entry_Prefix (P_Type)
5368
           and then not In_Open_Scopes (P_Name)
5369
           and then (not Is_Concurrent_Type (Etype (P_Name))
5370
                       or else not In_Open_Scopes (Etype (P_Name)))
5371
         then
5372
            --  Call to protected operation or entry. Type checking is
5373
            --  needed on the prefix.
5374
 
5375
            Analyze_Selected_Component (N);
5376
 
5377
         elsif (In_Open_Scopes (P_Name)
5378
                  and then Ekind (P_Name) /= E_Void
5379
                  and then not Is_Overloadable (P_Name))
5380
           or else (Is_Concurrent_Type (Etype (P_Name))
5381
                      and then In_Open_Scopes (Etype (P_Name)))
5382
         then
5383
            --  Prefix denotes an enclosing loop, block, or task, i.e. an
5384
            --  enclosing construct that is not a subprogram or accept.
5385
 
5386
            Find_Expanded_Name (N);
5387
 
5388
         elsif Ekind (P_Name) = E_Package then
5389
            Find_Expanded_Name (N);
5390
 
5391
         elsif Is_Overloadable (P_Name) then
5392
 
5393
            --  The subprogram may be a renaming (of an enclosing scope) as
5394
            --  in the case of the name of the generic within an instantiation.
5395
 
5396
            if (Ekind (P_Name) = E_Procedure
5397
                 or else Ekind (P_Name) = E_Function)
5398
              and then Present (Alias (P_Name))
5399
              and then Is_Generic_Instance (Alias (P_Name))
5400
            then
5401
               P_Name := Alias (P_Name);
5402
            end if;
5403
 
5404
            if Is_Overloaded (P) then
5405
 
5406
               --  The prefix must resolve to a unique enclosing construct
5407
 
5408
               declare
5409
                  Found : Boolean := False;
5410
                  Ind   : Interp_Index;
5411
                  It    : Interp;
5412
 
5413
               begin
5414
                  Get_First_Interp (P, Ind, It);
5415
                  while Present (It.Nam) loop
5416
                     if In_Open_Scopes (It.Nam) then
5417
                        if Found then
5418
                           Error_Msg_N (
5419
                              "prefix must be unique enclosing scope", N);
5420
                           Set_Entity (N, Any_Id);
5421
                           Set_Etype  (N, Any_Type);
5422
                           return;
5423
 
5424
                        else
5425
                           Found := True;
5426
                           P_Name := It.Nam;
5427
                        end if;
5428
                     end if;
5429
 
5430
                     Get_Next_Interp (Ind, It);
5431
                  end loop;
5432
               end;
5433
            end if;
5434
 
5435
            if In_Open_Scopes (P_Name) then
5436
               Set_Entity (P, P_Name);
5437
               Set_Is_Overloaded (P, False);
5438
               Find_Expanded_Name (N);
5439
 
5440
            else
5441
               --  If no interpretation as an expanded name is possible, it
5442
               --  must be a selected component of a record returned by a
5443
               --  function call. Reformat prefix as a function call, the rest
5444
               --  is done by type resolution. If the prefix is procedure or
5445
               --  entry, as is P.X; this is an error.
5446
 
5447
               if Ekind (P_Name) /= E_Function
5448
                 and then (not Is_Overloaded (P)
5449
                             or else
5450
                           Nkind (Parent (N)) = N_Procedure_Call_Statement)
5451
               then
5452
                  --  Prefix may mention a package that is hidden by a local
5453
                  --  declaration: let the user know. Scan the full homonym
5454
                  --  chain, the candidate package may be anywhere on it.
5455
 
5456
                  if Present (Homonym (Current_Entity (P_Name))) then
5457
 
5458
                     P_Name := Current_Entity (P_Name);
5459
 
5460
                     while Present (P_Name) loop
5461
                        exit when Ekind (P_Name) = E_Package;
5462
                        P_Name := Homonym (P_Name);
5463
                     end loop;
5464
 
5465
                     if Present (P_Name) then
5466
                        Error_Msg_Sloc := Sloc (Entity (Prefix (N)));
5467
 
5468
                        Error_Msg_NE
5469
                          ("package& is hidden by declaration#",
5470
                            N, P_Name);
5471
 
5472
                        Set_Entity (Prefix (N), P_Name);
5473
                        Find_Expanded_Name (N);
5474
                        return;
5475
                     else
5476
                        P_Name := Entity (Prefix (N));
5477
                     end if;
5478
                  end if;
5479
 
5480
                  Error_Msg_NE
5481
                    ("invalid prefix in selected component&", N, P_Name);
5482
                  Change_Selected_Component_To_Expanded_Name (N);
5483
                  Set_Entity (N, Any_Id);
5484
                  Set_Etype (N, Any_Type);
5485
 
5486
               else
5487
                  Nam := New_Copy (P);
5488
                  Save_Interps (P, Nam);
5489
                  Rewrite (P,
5490
                    Make_Function_Call (Sloc (P), Name => Nam));
5491
                  Analyze_Call (P);
5492
                  Analyze_Selected_Component (N);
5493
               end if;
5494
            end if;
5495
 
5496
         --  Remaining cases generate various error messages
5497
 
5498
         else
5499
            --  Format node as expanded name, to avoid cascaded errors
5500
 
5501
            Change_Selected_Component_To_Expanded_Name (N);
5502
            Set_Entity  (N, Any_Id);
5503
            Set_Etype   (N, Any_Type);
5504
 
5505
            --  Issue error message, but avoid this if error issued already.
5506
            --  Use identifier of prefix if one is available.
5507
 
5508
            if P_Name = Any_Id  then
5509
               null;
5510
 
5511
            elsif Ekind (P_Name) = E_Void then
5512
               Premature_Usage (P);
5513
 
5514
            elsif Nkind (P) /= N_Attribute_Reference then
5515
               Error_Msg_N (
5516
                "invalid prefix in selected component&", P);
5517
 
5518
               if Is_Access_Type (P_Type)
5519
                 and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type
5520
               then
5521
                  Error_Msg_N
5522
                    ("\dereference must not be of an incomplete type " &
5523
                       "(RM 3.10.1)", P);
5524
               end if;
5525
 
5526
            else
5527
               Error_Msg_N (
5528
                "invalid prefix in selected component", P);
5529
            end if;
5530
         end if;
5531
 
5532
      else
5533
         --  If prefix is not the name of an entity, it must be an expression,
5534
         --  whose type is appropriate for a record. This is determined by
5535
         --  type resolution.
5536
 
5537
         Analyze_Selected_Component (N);
5538
      end if;
5539
   end Find_Selected_Component;
5540
 
5541
   ---------------
5542
   -- Find_Type --
5543
   ---------------
5544
 
5545
   procedure Find_Type (N : Node_Id) is
5546
      C      : Entity_Id;
5547
      Typ    : Entity_Id;
5548
      T      : Entity_Id;
5549
      T_Name : Entity_Id;
5550
 
5551
   begin
5552
      if N = Error then
5553
         return;
5554
 
5555
      elsif Nkind (N) = N_Attribute_Reference then
5556
 
5557
         --  Class attribute. This is not valid in Ada 83 mode, but we do not
5558
         --  need to enforce that at this point, since the declaration of the
5559
         --  tagged type in the prefix would have been flagged already.
5560
 
5561
         if Attribute_Name (N) = Name_Class then
5562
            Check_Restriction (No_Dispatch, N);
5563
            Find_Type (Prefix (N));
5564
 
5565
            --  Propagate error from bad prefix
5566
 
5567
            if Etype (Prefix (N)) = Any_Type then
5568
               Set_Entity (N, Any_Type);
5569
               Set_Etype  (N, Any_Type);
5570
               return;
5571
            end if;
5572
 
5573
            T := Base_Type (Entity (Prefix (N)));
5574
 
5575
            --  Case where type is not known to be tagged. Its appearance in
5576
            --  the prefix of the 'Class attribute indicates that the full view
5577
            --  will be tagged.
5578
 
5579
            if not Is_Tagged_Type (T) then
5580
               if Ekind (T) = E_Incomplete_Type then
5581
 
5582
                  --  It is legal to denote the class type of an incomplete
5583
                  --  type. The full type will have to be tagged, of course.
5584
                  --  In Ada 2005 this usage is declared obsolescent, so we
5585
                  --  warn accordingly.
5586
 
5587
                  --  ??? This test is temporarily disabled (always False)
5588
                  --  because it causes an unwanted warning on GNAT sources
5589
                  --  (built with -gnatg, which includes Warn_On_Obsolescent_
5590
                  --  Feature). Once this issue is cleared in the sources, it
5591
                  --  can be enabled.
5592
 
5593
                  if not Is_Tagged_Type (T)
5594
                    and then Ada_Version >= Ada_05
5595
                    and then Warn_On_Obsolescent_Feature
5596
                    and then False
5597
                  then
5598
                     Error_Msg_N
5599
                       ("applying 'Class to an untagged incomplete type"
5600
                         & " is an obsolescent feature  (RM J.11)", N);
5601
                  end if;
5602
 
5603
                  Set_Is_Tagged_Type (T);
5604
                  Set_Primitive_Operations (T, New_Elmt_List);
5605
                  Make_Class_Wide_Type (T);
5606
                  Set_Entity (N, Class_Wide_Type (T));
5607
                  Set_Etype  (N, Class_Wide_Type (T));
5608
 
5609
               elsif Ekind (T) = E_Private_Type
5610
                 and then not Is_Generic_Type (T)
5611
                 and then In_Private_Part (Scope (T))
5612
               then
5613
                  --  The Class attribute can be applied to an untagged private
5614
                  --  type fulfilled by a tagged type prior to the full type
5615
                  --  declaration (but only within the parent package's private
5616
                  --  part). Create the class-wide type now and check that the
5617
                  --  full type is tagged later during its analysis. Note that
5618
                  --  we do not mark the private type as tagged, unlike the
5619
                  --  case of incomplete types, because the type must still
5620
                  --  appear untagged to outside units.
5621
 
5622
                  if No (Class_Wide_Type (T)) then
5623
                     Make_Class_Wide_Type (T);
5624
                  end if;
5625
 
5626
                  Set_Entity (N, Class_Wide_Type (T));
5627
                  Set_Etype  (N, Class_Wide_Type (T));
5628
 
5629
               else
5630
                  --  Should we introduce a type Any_Tagged and use Wrong_Type
5631
                  --  here, it would be a bit more consistent???
5632
 
5633
                  Error_Msg_NE
5634
                    ("tagged type required, found}",
5635
                     Prefix (N), First_Subtype (T));
5636
                  Set_Entity (N, Any_Type);
5637
                  return;
5638
               end if;
5639
 
5640
            --  Case of tagged type
5641
 
5642
            else
5643
               if Is_Concurrent_Type (T) then
5644
                  if No (Corresponding_Record_Type (Entity (Prefix (N)))) then
5645
 
5646
                     --  Previous error. Use current type, which at least
5647
                     --  provides some operations.
5648
 
5649
                     C := Entity (Prefix (N));
5650
 
5651
                  else
5652
                     C := Class_Wide_Type
5653
                            (Corresponding_Record_Type (Entity (Prefix (N))));
5654
                  end if;
5655
 
5656
               else
5657
                  C := Class_Wide_Type (Entity (Prefix (N)));
5658
               end if;
5659
 
5660
               Set_Entity_With_Style_Check (N, C);
5661
               Generate_Reference (C, N);
5662
               Set_Etype (N, C);
5663
            end if;
5664
 
5665
         --  Base attribute, not allowed in Ada 83
5666
 
5667
         elsif Attribute_Name (N) = Name_Base then
5668
            if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5669
               Error_Msg_N
5670
                 ("(Ada 83) Base attribute not allowed in subtype mark", N);
5671
 
5672
            else
5673
               Find_Type (Prefix (N));
5674
               Typ := Entity (Prefix (N));
5675
 
5676
               if Ada_Version >= Ada_95
5677
                 and then not Is_Scalar_Type (Typ)
5678
                 and then not Is_Generic_Type (Typ)
5679
               then
5680
                  Error_Msg_N
5681
                    ("prefix of Base attribute must be scalar type",
5682
                      Prefix (N));
5683
 
5684
               elsif Sloc (Typ) = Standard_Location
5685
                 and then Base_Type (Typ) = Typ
5686
                 and then Warn_On_Redundant_Constructs
5687
               then
5688
                  Error_Msg_NE
5689
                    ("?redundant attribute, & is its own base type", N, Typ);
5690
               end if;
5691
 
5692
               T := Base_Type (Typ);
5693
 
5694
               --  Rewrite attribute reference with type itself (see similar
5695
               --  processing in Analyze_Attribute, case Base). Preserve
5696
               --  prefix if present, for other legality checks.
5697
 
5698
               if Nkind (Prefix (N)) = N_Expanded_Name then
5699
                  Rewrite (N,
5700
                     Make_Expanded_Name (Sloc (N),
5701
                       Chars         => Chars (T),
5702
                       Prefix        => New_Copy (Prefix (Prefix (N))),
5703
                       Selector_Name => New_Reference_To (T, Sloc (N))));
5704
 
5705
               else
5706
                  Rewrite (N, New_Reference_To (T, Sloc (N)));
5707
               end if;
5708
 
5709
               Set_Entity (N, T);
5710
               Set_Etype (N, T);
5711
            end if;
5712
 
5713
         elsif Attribute_Name (N) = Name_Stub_Type then
5714
 
5715
            --  This is handled in Analyze_Attribute
5716
 
5717
            Analyze (N);
5718
 
5719
         --  All other attributes are invalid in a subtype mark
5720
 
5721
         else
5722
            Error_Msg_N ("invalid attribute in subtype mark", N);
5723
         end if;
5724
 
5725
      else
5726
         Analyze (N);
5727
 
5728
         if Is_Entity_Name (N) then
5729
            T_Name := Entity (N);
5730
         else
5731
            Error_Msg_N ("subtype mark required in this context", N);
5732
            Set_Etype (N, Any_Type);
5733
            return;
5734
         end if;
5735
 
5736
         if T_Name  = Any_Id or else Etype (N) = Any_Type then
5737
 
5738
            --  Undefined id. Make it into a valid type
5739
 
5740
            Set_Entity (N, Any_Type);
5741
 
5742
         elsif not Is_Type (T_Name)
5743
           and then T_Name /= Standard_Void_Type
5744
         then
5745
            Error_Msg_Sloc := Sloc (T_Name);
5746
            Error_Msg_N ("subtype mark required in this context", N);
5747
            Error_Msg_NE ("\\found & declared#", N, T_Name);
5748
            Set_Entity (N, Any_Type);
5749
 
5750
         else
5751
            --  If the type is an incomplete type created to handle
5752
            --  anonymous access components of a record type, then the
5753
            --  incomplete type is the visible entity and subsequent
5754
            --  references will point to it. Mark the original full
5755
            --  type as referenced, to prevent spurious warnings.
5756
 
5757
            if Is_Incomplete_Type (T_Name)
5758
              and then Present (Full_View (T_Name))
5759
              and then not Comes_From_Source (T_Name)
5760
            then
5761
               Set_Referenced (Full_View (T_Name));
5762
            end if;
5763
 
5764
            T_Name := Get_Full_View (T_Name);
5765
 
5766
            --  Ada 2005 (AI-251, AI-50217): Handle interfaces visible through
5767
            --  limited-with clauses
5768
 
5769
            if From_With_Type (T_Name)
5770
              and then Ekind (T_Name) in Incomplete_Kind
5771
              and then Present (Non_Limited_View (T_Name))
5772
              and then Is_Interface (Non_Limited_View (T_Name))
5773
            then
5774
               T_Name := Non_Limited_View (T_Name);
5775
            end if;
5776
 
5777
            if In_Open_Scopes (T_Name) then
5778
               if Ekind (Base_Type (T_Name)) = E_Task_Type then
5779
 
5780
                  --  In Ada 2005, a task name can be used in an access
5781
                  --  definition within its own body. It cannot be used
5782
                  --  in the discriminant part of the task declaration,
5783
                  --  nor anywhere else in the declaration because entries
5784
                  --  cannot have access parameters.
5785
 
5786
                  if Ada_Version >= Ada_05
5787
                    and then Nkind (Parent (N)) = N_Access_Definition
5788
                  then
5789
                     Set_Entity (N, T_Name);
5790
                     Set_Etype  (N, T_Name);
5791
 
5792
                     if Has_Completion (T_Name) then
5793
                        return;
5794
 
5795
                     else
5796
                        Error_Msg_N
5797
                          ("task type cannot be used as type mark " &
5798
                           "within its own declaration", N);
5799
                     end if;
5800
 
5801
                  else
5802
                     Error_Msg_N
5803
                       ("task type cannot be used as type mark " &
5804
                        "within its own spec or body", N);
5805
                  end if;
5806
 
5807
               elsif Ekind (Base_Type (T_Name)) = E_Protected_Type then
5808
 
5809
                  --  In Ada 2005, a protected name can be used in an access
5810
                  --  definition within its own body.
5811
 
5812
                  if Ada_Version >= Ada_05
5813
                    and then Nkind (Parent (N)) = N_Access_Definition
5814
                  then
5815
                     Set_Entity (N, T_Name);
5816
                     Set_Etype  (N, T_Name);
5817
                     return;
5818
 
5819
                  else
5820
                     Error_Msg_N
5821
                       ("protected type cannot be used as type mark " &
5822
                        "within its own spec or body", N);
5823
                  end if;
5824
 
5825
               else
5826
                  Error_Msg_N ("type declaration cannot refer to itself", N);
5827
               end if;
5828
 
5829
               Set_Etype (N, Any_Type);
5830
               Set_Entity (N, Any_Type);
5831
               Set_Error_Posted (T_Name);
5832
               return;
5833
            end if;
5834
 
5835
            Set_Entity (N, T_Name);
5836
            Set_Etype  (N, T_Name);
5837
         end if;
5838
      end if;
5839
 
5840
      if Present (Etype (N)) and then Comes_From_Source (N) then
5841
         if Is_Fixed_Point_Type (Etype (N)) then
5842
            Check_Restriction (No_Fixed_Point, N);
5843
         elsif Is_Floating_Point_Type (Etype (N)) then
5844
            Check_Restriction (No_Floating_Point, N);
5845
         end if;
5846
      end if;
5847
   end Find_Type;
5848
 
5849
   ------------------------------------
5850
   -- Has_Implicit_Character_Literal --
5851
   ------------------------------------
5852
 
5853
   function Has_Implicit_Character_Literal (N : Node_Id) return Boolean is
5854
      Id      : Entity_Id;
5855
      Found   : Boolean := False;
5856
      P       : constant Entity_Id := Entity (Prefix (N));
5857
      Priv_Id : Entity_Id := Empty;
5858
 
5859
   begin
5860
      if Ekind (P) = E_Package
5861
        and then not In_Open_Scopes (P)
5862
      then
5863
         Priv_Id := First_Private_Entity (P);
5864
      end if;
5865
 
5866
      if P = Standard_Standard then
5867
         Change_Selected_Component_To_Expanded_Name (N);
5868
         Rewrite (N, Selector_Name (N));
5869
         Analyze (N);
5870
         Set_Etype (Original_Node (N), Standard_Character);
5871
         return True;
5872
      end if;
5873
 
5874
      Id := First_Entity (P);
5875
      while Present (Id)
5876
        and then Id /= Priv_Id
5877
      loop
5878
         if Is_Standard_Character_Type (Id)
5879
           and then Id = Base_Type (Id)
5880
         then
5881
            --  We replace the node with the literal itself, resolve as a
5882
            --  character, and set the type correctly.
5883
 
5884
            if not Found then
5885
               Change_Selected_Component_To_Expanded_Name (N);
5886
               Rewrite (N, Selector_Name (N));
5887
               Analyze (N);
5888
               Set_Etype (N, Id);
5889
               Set_Etype (Original_Node (N), Id);
5890
               Found := True;
5891
 
5892
            else
5893
               --  More than one type derived from Character in given scope.
5894
               --  Collect all possible interpretations.
5895
 
5896
               Add_One_Interp (N, Id, Id);
5897
            end if;
5898
         end if;
5899
 
5900
         Next_Entity (Id);
5901
      end loop;
5902
 
5903
      return Found;
5904
   end Has_Implicit_Character_Literal;
5905
 
5906
   ----------------------
5907
   -- Has_Private_With --
5908
   ----------------------
5909
 
5910
   function Has_Private_With (E : Entity_Id) return Boolean is
5911
      Comp_Unit : constant Node_Id := Cunit (Current_Sem_Unit);
5912
      Item      : Node_Id;
5913
 
5914
   begin
5915
      Item := First (Context_Items (Comp_Unit));
5916
      while Present (Item) loop
5917
         if Nkind (Item) = N_With_Clause
5918
           and then Private_Present (Item)
5919
           and then Entity (Name (Item)) = E
5920
         then
5921
            return True;
5922
         end if;
5923
 
5924
         Next (Item);
5925
      end loop;
5926
 
5927
      return False;
5928
   end Has_Private_With;
5929
 
5930
   ---------------------------
5931
   -- Has_Implicit_Operator --
5932
   ---------------------------
5933
 
5934
   function Has_Implicit_Operator (N : Node_Id) return Boolean is
5935
      Op_Id   : constant Name_Id   := Chars (Selector_Name (N));
5936
      P       : constant Entity_Id := Entity (Prefix (N));
5937
      Id      : Entity_Id;
5938
      Priv_Id : Entity_Id := Empty;
5939
 
5940
      procedure Add_Implicit_Operator
5941
        (T       : Entity_Id;
5942
         Op_Type : Entity_Id := Empty);
5943
      --  Add implicit interpretation to node N, using the type for which a
5944
      --  predefined operator exists. If the operator yields a boolean type,
5945
      --  the Operand_Type is implicitly referenced by the operator, and a
5946
      --  reference to it must be generated.
5947
 
5948
      ---------------------------
5949
      -- Add_Implicit_Operator --
5950
      ---------------------------
5951
 
5952
      procedure Add_Implicit_Operator
5953
        (T       : Entity_Id;
5954
         Op_Type : Entity_Id := Empty)
5955
      is
5956
         Predef_Op : Entity_Id;
5957
 
5958
      begin
5959
         Predef_Op := Current_Entity (Selector_Name (N));
5960
 
5961
         while Present (Predef_Op)
5962
           and then Scope (Predef_Op) /= Standard_Standard
5963
         loop
5964
            Predef_Op := Homonym (Predef_Op);
5965
         end loop;
5966
 
5967
         if Nkind (N) = N_Selected_Component then
5968
            Change_Selected_Component_To_Expanded_Name (N);
5969
         end if;
5970
 
5971
         Add_One_Interp (N, Predef_Op, T);
5972
 
5973
         --  For operators with unary and binary interpretations, add both
5974
 
5975
         if Present (Homonym (Predef_Op)) then
5976
            Add_One_Interp (N, Homonym (Predef_Op), T);
5977
         end if;
5978
 
5979
         --  The node is a reference to a predefined operator, and
5980
         --  an implicit reference to the type of its operands.
5981
 
5982
         if Present (Op_Type) then
5983
            Generate_Operator_Reference (N, Op_Type);
5984
         else
5985
            Generate_Operator_Reference (N, T);
5986
         end if;
5987
      end Add_Implicit_Operator;
5988
 
5989
   --  Start of processing for Has_Implicit_Operator
5990
 
5991
   begin
5992
      if Ekind (P) = E_Package
5993
        and then not In_Open_Scopes (P)
5994
      then
5995
         Priv_Id := First_Private_Entity (P);
5996
      end if;
5997
 
5998
      Id := First_Entity (P);
5999
 
6000
      case Op_Id is
6001
 
6002
         --  Boolean operators: an implicit declaration exists if the scope
6003
         --  contains a declaration for a derived Boolean type, or for an
6004
         --  array of Boolean type.
6005
 
6006
         when Name_Op_And | Name_Op_Not | Name_Op_Or  | Name_Op_Xor =>
6007
            while Id  /= Priv_Id loop
6008
               if Valid_Boolean_Arg (Id)
6009
                 and then Id = Base_Type (Id)
6010
               then
6011
                  Add_Implicit_Operator (Id);
6012
                  return True;
6013
               end if;
6014
 
6015
               Next_Entity (Id);
6016
            end loop;
6017
 
6018
         --  Equality: look for any non-limited type (result is Boolean)
6019
 
6020
         when Name_Op_Eq | Name_Op_Ne =>
6021
            while Id  /= Priv_Id loop
6022
               if Is_Type (Id)
6023
                 and then not Is_Limited_Type (Id)
6024
                 and then Id = Base_Type (Id)
6025
               then
6026
                  Add_Implicit_Operator (Standard_Boolean, Id);
6027
                  return True;
6028
               end if;
6029
 
6030
               Next_Entity (Id);
6031
            end loop;
6032
 
6033
         --  Comparison operators: scalar type, or array of scalar
6034
 
6035
         when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge =>
6036
            while Id  /= Priv_Id loop
6037
               if (Is_Scalar_Type (Id)
6038
                 or else (Is_Array_Type (Id)
6039
                           and then Is_Scalar_Type (Component_Type (Id))))
6040
                 and then Id = Base_Type (Id)
6041
               then
6042
                  Add_Implicit_Operator (Standard_Boolean, Id);
6043
                  return True;
6044
               end if;
6045
 
6046
               Next_Entity (Id);
6047
            end loop;
6048
 
6049
         --  Arithmetic operators: any numeric type
6050
 
6051
         when Name_Op_Abs      |
6052
              Name_Op_Add      |
6053
              Name_Op_Mod      |
6054
              Name_Op_Rem      |
6055
              Name_Op_Subtract |
6056
              Name_Op_Multiply |
6057
              Name_Op_Divide   |
6058
              Name_Op_Expon    =>
6059
            while Id  /= Priv_Id loop
6060
               if Is_Numeric_Type (Id)
6061
                 and then Id = Base_Type (Id)
6062
               then
6063
                  Add_Implicit_Operator (Id);
6064
                  return True;
6065
               end if;
6066
 
6067
               Next_Entity (Id);
6068
            end loop;
6069
 
6070
         --  Concatenation: any one-dimensional array type
6071
 
6072
         when Name_Op_Concat =>
6073
            while Id  /= Priv_Id loop
6074
               if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1
6075
                 and then Id = Base_Type (Id)
6076
               then
6077
                  Add_Implicit_Operator (Id);
6078
                  return True;
6079
               end if;
6080
 
6081
               Next_Entity (Id);
6082
            end loop;
6083
 
6084
         --  What is the others condition here? Should we be using a
6085
         --  subtype of Name_Id that would restrict to operators ???
6086
 
6087
         when others => null;
6088
      end case;
6089
 
6090
      --  If we fall through, then we do not have an implicit operator
6091
 
6092
      return False;
6093
 
6094
   end Has_Implicit_Operator;
6095
 
6096
   --------------------
6097
   -- In_Open_Scopes --
6098
   --------------------
6099
 
6100
   function In_Open_Scopes (S : Entity_Id) return Boolean is
6101
   begin
6102
      --  Several scope stacks are maintained by Scope_Stack. The base of the
6103
      --  currently active scope stack is denoted by the Is_Active_Stack_Base
6104
      --  flag in the scope stack entry. Note that the scope stacks used to
6105
      --  simply be delimited implicitly by the presence of Standard_Standard
6106
      --  at their base, but there now are cases where this is not sufficient
6107
      --  because Standard_Standard actually may appear in the middle of the
6108
      --  active set of scopes.
6109
 
6110
      for J in reverse 0 .. Scope_Stack.Last loop
6111
         if Scope_Stack.Table (J).Entity = S then
6112
            return True;
6113
         end if;
6114
 
6115
         --  Check Is_Active_Stack_Base to tell us when to stop, as there are
6116
         --  cases where Standard_Standard appears in the middle of the active
6117
         --  set of scopes. This affects the declaration and overriding of
6118
         --  private inherited operations in instantiations of generic child
6119
         --  units.
6120
 
6121
         exit when Scope_Stack.Table (J).Is_Active_Stack_Base;
6122
      end loop;
6123
 
6124
      return False;
6125
   end In_Open_Scopes;
6126
 
6127
   -----------------------------
6128
   -- Inherit_Renamed_Profile --
6129
   -----------------------------
6130
 
6131
   procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id) is
6132
      New_F : Entity_Id;
6133
      Old_F : Entity_Id;
6134
      Old_T : Entity_Id;
6135
      New_T : Entity_Id;
6136
 
6137
   begin
6138
      if Ekind (Old_S) = E_Operator then
6139
         New_F := First_Formal (New_S);
6140
 
6141
         while Present (New_F) loop
6142
            Set_Etype (New_F, Base_Type (Etype (New_F)));
6143
            Next_Formal (New_F);
6144
         end loop;
6145
 
6146
         Set_Etype (New_S, Base_Type (Etype (New_S)));
6147
 
6148
      else
6149
         New_F := First_Formal (New_S);
6150
         Old_F := First_Formal (Old_S);
6151
 
6152
         while Present (New_F) loop
6153
            New_T := Etype (New_F);
6154
            Old_T := Etype (Old_F);
6155
 
6156
            --  If the new type is a renaming of the old one, as is the
6157
            --  case for actuals in instances, retain its name, to simplify
6158
            --  later disambiguation.
6159
 
6160
            if Nkind (Parent (New_T)) = N_Subtype_Declaration
6161
              and then Is_Entity_Name (Subtype_Indication (Parent (New_T)))
6162
              and then Entity (Subtype_Indication (Parent (New_T))) = Old_T
6163
            then
6164
               null;
6165
            else
6166
               Set_Etype (New_F, Old_T);
6167
            end if;
6168
 
6169
            Next_Formal (New_F);
6170
            Next_Formal (Old_F);
6171
         end loop;
6172
 
6173
         if Ekind (Old_S) = E_Function
6174
           or else Ekind (Old_S) = E_Enumeration_Literal
6175
         then
6176
            Set_Etype (New_S, Etype (Old_S));
6177
         end if;
6178
      end if;
6179
   end Inherit_Renamed_Profile;
6180
 
6181
   ----------------
6182
   -- Initialize --
6183
   ----------------
6184
 
6185
   procedure Initialize is
6186
   begin
6187
      Urefs.Init;
6188
   end Initialize;
6189
 
6190
   -------------------------
6191
   -- Install_Use_Clauses --
6192
   -------------------------
6193
 
6194
   procedure Install_Use_Clauses
6195
     (Clause             : Node_Id;
6196
      Force_Installation : Boolean := False)
6197
   is
6198
      U  : Node_Id;
6199
      P  : Node_Id;
6200
      Id : Entity_Id;
6201
 
6202
   begin
6203
      U := Clause;
6204
      while Present (U) loop
6205
 
6206
         --  Case of USE package
6207
 
6208
         if Nkind (U) = N_Use_Package_Clause then
6209
            P := First (Names (U));
6210
            while Present (P) loop
6211
               Id := Entity (P);
6212
 
6213
               if Ekind (Id) = E_Package then
6214
                  if In_Use (Id) then
6215
                     Note_Redundant_Use (P);
6216
 
6217
                  elsif Present (Renamed_Object (Id))
6218
                    and then In_Use (Renamed_Object (Id))
6219
                  then
6220
                     Note_Redundant_Use (P);
6221
 
6222
                  elsif Force_Installation or else Applicable_Use (P) then
6223
                     Use_One_Package (Id, U);
6224
 
6225
                  end if;
6226
               end if;
6227
 
6228
               Next (P);
6229
            end loop;
6230
 
6231
         --  Case of USE TYPE
6232
 
6233
         else
6234
            P := First (Subtype_Marks (U));
6235
            while Present (P) loop
6236
               if not Is_Entity_Name (P)
6237
                 or else No (Entity (P))
6238
               then
6239
                  null;
6240
 
6241
               elsif Entity (P) /= Any_Type then
6242
                  Use_One_Type (P);
6243
               end if;
6244
 
6245
               Next (P);
6246
            end loop;
6247
         end if;
6248
 
6249
         Next_Use_Clause (U);
6250
      end loop;
6251
   end Install_Use_Clauses;
6252
 
6253
   -------------------------------------
6254
   -- Is_Appropriate_For_Entry_Prefix --
6255
   -------------------------------------
6256
 
6257
   function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is
6258
      P_Type : Entity_Id := T;
6259
 
6260
   begin
6261
      if Is_Access_Type (P_Type) then
6262
         P_Type := Designated_Type (P_Type);
6263
      end if;
6264
 
6265
      return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type);
6266
   end Is_Appropriate_For_Entry_Prefix;
6267
 
6268
   -------------------------------
6269
   -- Is_Appropriate_For_Record --
6270
   -------------------------------
6271
 
6272
   function Is_Appropriate_For_Record (T : Entity_Id) return Boolean is
6273
 
6274
      function Has_Components (T1 : Entity_Id) return Boolean;
6275
      --  Determine if given type has components (i.e. is either a record
6276
      --  type or a type that has discriminants).
6277
 
6278
      --------------------
6279
      -- Has_Components --
6280
      --------------------
6281
 
6282
      function Has_Components (T1 : Entity_Id) return Boolean is
6283
      begin
6284
         return Is_Record_Type (T1)
6285
           or else (Is_Private_Type (T1) and then Has_Discriminants (T1))
6286
           or else (Is_Task_Type (T1) and then Has_Discriminants (T1))
6287
           or else (Is_Incomplete_Type (T1)
6288
                     and then From_With_Type (T1)
6289
                     and then Present (Non_Limited_View (T1))
6290
                     and then Is_Record_Type
6291
                                (Get_Full_View (Non_Limited_View (T1))));
6292
      end Has_Components;
6293
 
6294
   --  Start of processing for Is_Appropriate_For_Record
6295
 
6296
   begin
6297
      return
6298
        Present (T)
6299
          and then (Has_Components (T)
6300
                     or else (Is_Access_Type (T)
6301
                               and then Has_Components (Designated_Type (T))));
6302
   end Is_Appropriate_For_Record;
6303
 
6304
   ------------------------
6305
   -- Note_Redundant_Use --
6306
   ------------------------
6307
 
6308
   procedure Note_Redundant_Use (Clause : Node_Id) is
6309
      Pack_Name : constant Entity_Id := Entity (Clause);
6310
      Cur_Use   : constant Node_Id   := Current_Use_Clause (Pack_Name);
6311
      Decl      : constant Node_Id   := Parent (Clause);
6312
 
6313
      Prev_Use   : Node_Id := Empty;
6314
      Redundant  : Node_Id := Empty;
6315
      --  The Use_Clause which is actually redundant. In the simplest case it
6316
      --  is Pack itself, but when we compile a body we install its context
6317
      --  before that of its spec, in which case it is the use_clause in the
6318
      --  spec that will appear to be redundant, and we want the warning to be
6319
      --  placed on the body. Similar complications appear when the redundancy
6320
      --  is between a child unit and one of its ancestors.
6321
 
6322
   begin
6323
      Set_Redundant_Use (Clause, True);
6324
 
6325
      if not Comes_From_Source (Clause)
6326
        or else In_Instance
6327
        or else not Warn_On_Redundant_Constructs
6328
      then
6329
         return;
6330
      end if;
6331
 
6332
      if not Is_Compilation_Unit (Current_Scope) then
6333
 
6334
         --  If the use_clause is in an inner scope, it is made redundant by
6335
         --  some clause in the current context, with one exception: If we're
6336
         --  compiling a nested package body, and the use_clause comes from the
6337
         --  corresponding spec, the clause is not necessarily fully redundant,
6338
         --  so we should not warn. If a warning was warranted, it would have
6339
         --  been given when the spec was processed.
6340
 
6341
         if Nkind (Parent (Decl)) = N_Package_Specification then
6342
            declare
6343
               Package_Spec_Entity : constant Entity_Id :=
6344
                                       Defining_Unit_Name (Parent (Decl));
6345
            begin
6346
               if In_Package_Body (Package_Spec_Entity) then
6347
                  return;
6348
               end if;
6349
            end;
6350
         end if;
6351
 
6352
         Redundant := Clause;
6353
         Prev_Use  := Cur_Use;
6354
 
6355
      elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
6356
         declare
6357
            Cur_Unit : constant Unit_Number_Type := Get_Source_Unit (Cur_Use);
6358
            New_Unit : constant Unit_Number_Type := Get_Source_Unit (Clause);
6359
            Scop     : Entity_Id;
6360
 
6361
         begin
6362
            if Cur_Unit = New_Unit then
6363
 
6364
               --  Redundant clause in same body
6365
 
6366
               Redundant := Clause;
6367
               Prev_Use  := Cur_Use;
6368
 
6369
            elsif Cur_Unit = Current_Sem_Unit then
6370
 
6371
               --  If the new clause is not in the current unit it has been
6372
               --  analyzed first, and it makes the other one redundant.
6373
               --  However, if the new clause appears in a subunit, Cur_Unit
6374
               --  is still the parent, and in that case the redundant one
6375
               --  is the one appearing in the subunit.
6376
 
6377
               if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then
6378
                  Redundant := Clause;
6379
                  Prev_Use  := Cur_Use;
6380
 
6381
               --  Most common case: redundant clause in body,
6382
               --  original clause in spec. Current scope is spec entity.
6383
 
6384
               elsif
6385
                 Current_Scope =
6386
                   Defining_Entity (
6387
                     Unit (Library_Unit (Cunit (Current_Sem_Unit))))
6388
               then
6389
                  Redundant := Cur_Use;
6390
                  Prev_Use  := Clause;
6391
 
6392
               else
6393
                  --  The new clause may appear in an unrelated unit, when
6394
                  --  the parents of a generic are being installed prior to
6395
                  --  instantiation. In this case there must be no warning.
6396
                  --  We detect this case by checking whether the current top
6397
                  --  of the stack is related to the current compilation.
6398
 
6399
                  Scop := Current_Scope;
6400
                  while Present (Scop)
6401
                    and then Scop /= Standard_Standard
6402
                  loop
6403
                     if Is_Compilation_Unit (Scop)
6404
                       and then not Is_Child_Unit (Scop)
6405
                     then
6406
                        return;
6407
 
6408
                     elsif Scop = Cunit_Entity (Current_Sem_Unit) then
6409
                        exit;
6410
                     end if;
6411
 
6412
                     Scop := Scope (Scop);
6413
                  end loop;
6414
 
6415
                  Redundant := Cur_Use;
6416
                  Prev_Use  := Clause;
6417
               end if;
6418
 
6419
            elsif New_Unit = Current_Sem_Unit then
6420
               Redundant := Clause;
6421
               Prev_Use  := Cur_Use;
6422
 
6423
            else
6424
               --  Neither is the current unit, so they appear in parent or
6425
               --  sibling units. Warning will be emitted elsewhere.
6426
 
6427
               return;
6428
            end if;
6429
         end;
6430
 
6431
      elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
6432
        and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit))))
6433
      then
6434
         --  Use_clause is in child unit of current unit, and the child unit
6435
         --  appears in the context of the body of the parent, so it has been
6436
         --  installed first, even though it is the redundant one. Depending on
6437
         --  their placement in the context, the visible or the private parts
6438
         --  of the two units, either might appear as redundant, but the
6439
         --  message has to be on the current unit.
6440
 
6441
         if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then
6442
            Redundant := Cur_Use;
6443
            Prev_Use  := Clause;
6444
         else
6445
            Redundant := Clause;
6446
            Prev_Use  := Cur_Use;
6447
         end if;
6448
 
6449
         --  If the new use clause appears in the private part of a parent unit
6450
         --  it may appear to be redundant w.r.t. a use clause in a child unit,
6451
         --  but the previous use clause was needed in the visible part of the
6452
         --  child, and no warning should be emitted.
6453
 
6454
         if Nkind (Parent (Decl)) = N_Package_Specification
6455
           and then
6456
             List_Containing (Decl) = Private_Declarations (Parent (Decl))
6457
         then
6458
            declare
6459
               Par : constant Entity_Id := Defining_Entity (Parent (Decl));
6460
               Spec : constant Node_Id  :=
6461
                        Specification (Unit (Cunit (Current_Sem_Unit)));
6462
 
6463
            begin
6464
               if Is_Compilation_Unit (Par)
6465
                 and then Par /= Cunit_Entity (Current_Sem_Unit)
6466
                 and then Parent (Cur_Use) = Spec
6467
                 and then
6468
                   List_Containing (Cur_Use) = Visible_Declarations (Spec)
6469
               then
6470
                  return;
6471
               end if;
6472
            end;
6473
         end if;
6474
 
6475
      --  Finally, if the current use clause is in the context then
6476
      --  the clause is redundant when it is nested within the unit.
6477
 
6478
      elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit
6479
        and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit
6480
        and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause)
6481
      then
6482
         Redundant := Clause;
6483
         Prev_Use  := Cur_Use;
6484
 
6485
      else
6486
         null;
6487
      end if;
6488
 
6489
      if Present (Redundant) then
6490
         Error_Msg_Sloc := Sloc (Prev_Use);
6491
         Error_Msg_NE
6492
           ("& is already use-visible through previous use clause #?",
6493
            Redundant, Pack_Name);
6494
      end if;
6495
   end Note_Redundant_Use;
6496
 
6497
   ---------------
6498
   -- Pop_Scope --
6499
   ---------------
6500
 
6501
   procedure Pop_Scope is
6502
      SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
6503
 
6504
   begin
6505
      if Debug_Flag_E then
6506
         Write_Info;
6507
      end if;
6508
 
6509
      Scope_Suppress           := SST.Save_Scope_Suppress;
6510
      Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top;
6511
      Check_Policy_List        := SST.Save_Check_Policy_List;
6512
 
6513
      if Debug_Flag_W then
6514
         Write_Str ("--> exiting scope: ");
6515
         Write_Name (Chars (Current_Scope));
6516
         Write_Str (", Depth=");
6517
         Write_Int (Int (Scope_Stack.Last));
6518
         Write_Eol;
6519
      end if;
6520
 
6521
      End_Use_Clauses (SST.First_Use_Clause);
6522
 
6523
      --  If the actions to be wrapped are still there they will get lost
6524
      --  causing incomplete code to be generated. It is better to abort in
6525
      --  this case (and we do the abort even with assertions off since the
6526
      --  penalty is incorrect code generation)
6527
 
6528
      if SST.Actions_To_Be_Wrapped_Before /= No_List
6529
           or else
6530
         SST.Actions_To_Be_Wrapped_After  /= No_List
6531
      then
6532
         return;
6533
      end if;
6534
 
6535
      --  Free last subprogram name if allocated, and pop scope
6536
 
6537
      Free (SST.Last_Subprogram_Name);
6538
      Scope_Stack.Decrement_Last;
6539
   end Pop_Scope;
6540
 
6541
   ---------------
6542
   -- Push_Scope --
6543
   ---------------
6544
 
6545
   procedure Push_Scope (S : Entity_Id) is
6546
      E : Entity_Id;
6547
 
6548
   begin
6549
      if Ekind (S) = E_Void then
6550
         null;
6551
 
6552
      --  Set scope depth if not a non-concurrent type, and we have not yet set
6553
      --  the scope depth. This means that we have the first occurrence of the
6554
      --  scope, and this is where the depth is set.
6555
 
6556
      elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
6557
        and then not Scope_Depth_Set (S)
6558
      then
6559
         if S = Standard_Standard then
6560
            Set_Scope_Depth_Value (S, Uint_0);
6561
 
6562
         elsif Is_Child_Unit (S) then
6563
            Set_Scope_Depth_Value (S, Uint_1);
6564
 
6565
         elsif not Is_Record_Type (Current_Scope) then
6566
            if Ekind (S) = E_Loop then
6567
               Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
6568
            else
6569
               Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
6570
            end if;
6571
         end if;
6572
      end if;
6573
 
6574
      Scope_Stack.Increment_Last;
6575
 
6576
      declare
6577
         SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
6578
 
6579
      begin
6580
         SST.Entity                        := S;
6581
         SST.Save_Scope_Suppress           := Scope_Suppress;
6582
         SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top;
6583
         SST.Save_Check_Policy_List        := Check_Policy_List;
6584
 
6585
         if Scope_Stack.Last > Scope_Stack.First then
6586
            SST.Component_Alignment_Default := Scope_Stack.Table
6587
                                                 (Scope_Stack.Last - 1).
6588
                                                   Component_Alignment_Default;
6589
         end if;
6590
 
6591
         SST.Last_Subprogram_Name           := null;
6592
         SST.Is_Transient                   := False;
6593
         SST.Node_To_Be_Wrapped             := Empty;
6594
         SST.Pending_Freeze_Actions         := No_List;
6595
         SST.Actions_To_Be_Wrapped_Before   := No_List;
6596
         SST.Actions_To_Be_Wrapped_After    := No_List;
6597
         SST.First_Use_Clause               := Empty;
6598
         SST.Is_Active_Stack_Base           := False;
6599
         SST.Previous_Visibility            := False;
6600
      end;
6601
 
6602
      if Debug_Flag_W then
6603
         Write_Str ("--> new scope: ");
6604
         Write_Name (Chars (Current_Scope));
6605
         Write_Str (", Id=");
6606
         Write_Int (Int (Current_Scope));
6607
         Write_Str (", Depth=");
6608
         Write_Int (Int (Scope_Stack.Last));
6609
         Write_Eol;
6610
      end if;
6611
 
6612
      --  Deal with copying flags from the previous scope to this one. This is
6613
      --  not necessary if either scope is standard, or if the new scope is a
6614
      --  child unit.
6615
 
6616
      if S /= Standard_Standard
6617
        and then Scope (S) /= Standard_Standard
6618
        and then not Is_Child_Unit (S)
6619
      then
6620
         E := Scope (S);
6621
 
6622
         if Nkind (E) not in N_Entity then
6623
            return;
6624
         end if;
6625
 
6626
         --  Copy categorization flags from Scope (S) to S, this is not done
6627
         --  when Scope (S) is Standard_Standard since propagation is from
6628
         --  library unit entity inwards. Copy other relevant attributes as
6629
         --  well (Discard_Names in particular).
6630
 
6631
         --  We only propagate inwards for library level entities,
6632
         --  inner level subprograms do not inherit the categorization.
6633
 
6634
         if Is_Library_Level_Entity (S) then
6635
            Set_Is_Preelaborated  (S, Is_Preelaborated (E));
6636
            Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
6637
            Set_Discard_Names     (S, Discard_Names (E));
6638
            Set_Suppress_Value_Tracking_On_Call
6639
                                  (S, Suppress_Value_Tracking_On_Call (E));
6640
            Set_Categorization_From_Scope (E => S, Scop => E);
6641
         end if;
6642
      end if;
6643
   end Push_Scope;
6644
 
6645
   ---------------------
6646
   -- Premature_Usage --
6647
   ---------------------
6648
 
6649
   procedure Premature_Usage (N : Node_Id) is
6650
      Kind : constant Node_Kind := Nkind (Parent (Entity (N)));
6651
      E    : Entity_Id := Entity (N);
6652
 
6653
   begin
6654
      --  Within an instance, the analysis of the actual for a formal object
6655
      --  does not see the name of the object itself. This is significant only
6656
      --  if the object is an aggregate, where its analysis does not do any
6657
      --  name resolution on component associations. (see 4717-008). In such a
6658
      --  case, look for the visible homonym on the chain.
6659
 
6660
      if In_Instance
6661
        and then Present (Homonym (E))
6662
      then
6663
         E := Homonym (E);
6664
 
6665
         while Present (E)
6666
           and then not In_Open_Scopes (Scope (E))
6667
         loop
6668
            E := Homonym (E);
6669
         end loop;
6670
 
6671
         if Present (E) then
6672
            Set_Entity (N, E);
6673
            Set_Etype (N, Etype (E));
6674
            return;
6675
         end if;
6676
      end if;
6677
 
6678
      if Kind  = N_Component_Declaration then
6679
         Error_Msg_N
6680
           ("component&! cannot be used before end of record declaration", N);
6681
 
6682
      elsif Kind  = N_Parameter_Specification then
6683
         Error_Msg_N
6684
           ("formal parameter&! cannot be used before end of specification",
6685
            N);
6686
 
6687
      elsif Kind  = N_Discriminant_Specification then
6688
         Error_Msg_N
6689
           ("discriminant&! cannot be used before end of discriminant part",
6690
            N);
6691
 
6692
      elsif Kind  = N_Procedure_Specification
6693
        or else Kind = N_Function_Specification
6694
      then
6695
         Error_Msg_N
6696
           ("subprogram&! cannot be used before end of its declaration",
6697
            N);
6698
 
6699
      elsif Kind = N_Full_Type_Declaration then
6700
         Error_Msg_N
6701
           ("type& cannot be used before end of its declaration!", N);
6702
 
6703
      else
6704
         Error_Msg_N
6705
           ("object& cannot be used before end of its declaration!", N);
6706
      end if;
6707
   end Premature_Usage;
6708
 
6709
   ------------------------
6710
   -- Present_System_Aux --
6711
   ------------------------
6712
 
6713
   function Present_System_Aux (N : Node_Id := Empty) return Boolean is
6714
      Loc      : Source_Ptr;
6715
      Aux_Name : Unit_Name_Type;
6716
      Unum     : Unit_Number_Type;
6717
      Withn    : Node_Id;
6718
      With_Sys : Node_Id;
6719
      The_Unit : Node_Id;
6720
 
6721
      function Find_System (C_Unit : Node_Id) return Entity_Id;
6722
      --  Scan context clause of compilation unit to find with_clause
6723
      --  for System.
6724
 
6725
      -----------------
6726
      -- Find_System --
6727
      -----------------
6728
 
6729
      function Find_System (C_Unit : Node_Id) return Entity_Id is
6730
         With_Clause : Node_Id;
6731
 
6732
      begin
6733
         With_Clause := First (Context_Items (C_Unit));
6734
         while Present (With_Clause) loop
6735
            if (Nkind (With_Clause) = N_With_Clause
6736
              and then Chars (Name (With_Clause)) = Name_System)
6737
              and then Comes_From_Source (With_Clause)
6738
            then
6739
               return With_Clause;
6740
            end if;
6741
 
6742
            Next (With_Clause);
6743
         end loop;
6744
 
6745
         return Empty;
6746
      end Find_System;
6747
 
6748
   --  Start of processing for Present_System_Aux
6749
 
6750
   begin
6751
      --  The child unit may have been loaded and analyzed already
6752
 
6753
      if Present (System_Aux_Id) then
6754
         return True;
6755
 
6756
      --  If no previous pragma for System.Aux, nothing to load
6757
 
6758
      elsif No (System_Extend_Unit) then
6759
         return False;
6760
 
6761
      --  Use the unit name given in the pragma to retrieve the unit.
6762
      --  Verify that System itself appears in the context clause of the
6763
      --  current compilation. If System is not present, an error will
6764
      --  have been reported already.
6765
 
6766
      else
6767
         With_Sys := Find_System (Cunit (Current_Sem_Unit));
6768
 
6769
         The_Unit := Unit (Cunit (Current_Sem_Unit));
6770
 
6771
         if No (With_Sys)
6772
           and then
6773
             (Nkind (The_Unit) = N_Package_Body
6774
                or else (Nkind (The_Unit) = N_Subprogram_Body
6775
                           and then
6776
                             not Acts_As_Spec (Cunit (Current_Sem_Unit))))
6777
         then
6778
            With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit)));
6779
         end if;
6780
 
6781
         if No (With_Sys)
6782
           and then Present (N)
6783
         then
6784
            --  If we are compiling a subunit, we need to examine its
6785
            --  context as well (Current_Sem_Unit is the parent unit);
6786
 
6787
            The_Unit := Parent (N);
6788
            while Nkind (The_Unit) /= N_Compilation_Unit loop
6789
               The_Unit := Parent (The_Unit);
6790
            end loop;
6791
 
6792
            if Nkind (Unit (The_Unit)) = N_Subunit then
6793
               With_Sys := Find_System (The_Unit);
6794
            end if;
6795
         end if;
6796
 
6797
         if No (With_Sys) then
6798
            return False;
6799
         end if;
6800
 
6801
         Loc := Sloc (With_Sys);
6802
         Get_Name_String (Chars (Expression (System_Extend_Unit)));
6803
         Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
6804
         Name_Buffer (1 .. 7) := "system.";
6805
         Name_Buffer (Name_Len + 8) := '%';
6806
         Name_Buffer (Name_Len + 9) := 's';
6807
         Name_Len := Name_Len + 9;
6808
         Aux_Name := Name_Find;
6809
 
6810
         Unum :=
6811
           Load_Unit
6812
             (Load_Name  => Aux_Name,
6813
              Required   => False,
6814
              Subunit    => False,
6815
              Error_Node => With_Sys);
6816
 
6817
         if Unum /= No_Unit then
6818
            Semantics (Cunit (Unum));
6819
            System_Aux_Id :=
6820
              Defining_Entity (Specification (Unit (Cunit (Unum))));
6821
 
6822
            Withn :=
6823
              Make_With_Clause (Loc,
6824
                Name =>
6825
                  Make_Expanded_Name (Loc,
6826
                    Chars  => Chars (System_Aux_Id),
6827
                    Prefix => New_Reference_To (Scope (System_Aux_Id), Loc),
6828
                    Selector_Name => New_Reference_To (System_Aux_Id, Loc)));
6829
 
6830
            Set_Entity (Name (Withn), System_Aux_Id);
6831
 
6832
            Set_Library_Unit       (Withn, Cunit (Unum));
6833
            Set_Corresponding_Spec (Withn, System_Aux_Id);
6834
            Set_First_Name         (Withn, True);
6835
            Set_Implicit_With      (Withn, True);
6836
 
6837
            Insert_After (With_Sys, Withn);
6838
            Mark_Rewrite_Insertion (Withn);
6839
            Set_Context_Installed (Withn);
6840
 
6841
            return True;
6842
 
6843
         --  Here if unit load failed
6844
 
6845
         else
6846
            Error_Msg_Name_1 := Name_System;
6847
            Error_Msg_Name_2 := Chars (Expression (System_Extend_Unit));
6848
            Error_Msg_N
6849
              ("extension package `%.%` does not exist",
6850
               Opt.System_Extend_Unit);
6851
            return False;
6852
         end if;
6853
      end if;
6854
   end Present_System_Aux;
6855
 
6856
   -------------------------
6857
   -- Restore_Scope_Stack --
6858
   -------------------------
6859
 
6860
   procedure Restore_Scope_Stack (Handle_Use : Boolean := True) is
6861
      E         : Entity_Id;
6862
      S         : Entity_Id;
6863
      Comp_Unit : Node_Id;
6864
      In_Child  : Boolean := False;
6865
      Full_Vis  : Boolean := True;
6866
      SS_Last   : constant Int := Scope_Stack.Last;
6867
 
6868
   begin
6869
      --  Restore visibility of previous scope stack, if any
6870
 
6871
      for J in reverse 0 .. Scope_Stack.Last loop
6872
         exit when  Scope_Stack.Table (J).Entity = Standard_Standard
6873
            or else No (Scope_Stack.Table (J).Entity);
6874
 
6875
         S := Scope_Stack.Table (J).Entity;
6876
 
6877
         if not Is_Hidden_Open_Scope (S) then
6878
 
6879
            --  If the parent scope is hidden, its entities are hidden as
6880
            --  well, unless the entity is the instantiation currently
6881
            --  being analyzed.
6882
 
6883
            if not Is_Hidden_Open_Scope (Scope (S))
6884
              or else not Analyzed (Parent (S))
6885
              or else Scope (S) = Standard_Standard
6886
            then
6887
               Set_Is_Immediately_Visible (S, True);
6888
            end if;
6889
 
6890
            E := First_Entity (S);
6891
            while Present (E) loop
6892
               if Is_Child_Unit (E) then
6893
                  if not From_With_Type (E) then
6894
                     Set_Is_Immediately_Visible (E,
6895
                       Is_Visible_Child_Unit (E) or else In_Open_Scopes (E));
6896
 
6897
                  else
6898
                     pragma Assert
6899
                       (Nkind (Parent (E)) = N_Defining_Program_Unit_Name
6900
                          and then
6901
                        Nkind (Parent (Parent (E))) = N_Package_Specification);
6902
                     Set_Is_Immediately_Visible (E,
6903
                       Limited_View_Installed (Parent (Parent (E))));
6904
                  end if;
6905
               else
6906
                  Set_Is_Immediately_Visible (E, True);
6907
               end if;
6908
 
6909
               Next_Entity (E);
6910
 
6911
               if not Full_Vis
6912
                 and then Is_Package_Or_Generic_Package (S)
6913
               then
6914
                  --  We are in the visible part of the package scope
6915
 
6916
                  exit when E = First_Private_Entity (S);
6917
               end if;
6918
            end loop;
6919
 
6920
            --  The visibility of child units (siblings of current compilation)
6921
            --  must be restored in any case. Their declarations may appear
6922
            --  after the private part of the parent.
6923
 
6924
            if not Full_Vis then
6925
               while Present (E) loop
6926
                  if Is_Child_Unit (E) then
6927
                     Set_Is_Immediately_Visible (E,
6928
                       Is_Visible_Child_Unit (E) or else In_Open_Scopes (E));
6929
                  end if;
6930
 
6931
                  Next_Entity (E);
6932
               end loop;
6933
            end if;
6934
         end if;
6935
 
6936
         if Is_Child_Unit (S)
6937
            and not In_Child     --  check only for current unit
6938
         then
6939
            In_Child := True;
6940
 
6941
            --  Restore visibility of parents according to whether the child
6942
            --  is private and whether we are in its visible part.
6943
 
6944
            Comp_Unit := Parent (Unit_Declaration_Node (S));
6945
 
6946
            if Nkind (Comp_Unit) = N_Compilation_Unit
6947
              and then Private_Present (Comp_Unit)
6948
            then
6949
               Full_Vis := True;
6950
 
6951
            elsif Is_Package_Or_Generic_Package (S)
6952
              and then (In_Private_Part (S) or else In_Package_Body (S))
6953
            then
6954
               Full_Vis := True;
6955
 
6956
            --  if S is the scope of some instance (which has already been
6957
            --  seen on the stack) it does not affect the visibility of
6958
            --  other scopes.
6959
 
6960
            elsif Is_Hidden_Open_Scope (S) then
6961
               null;
6962
 
6963
            elsif (Ekind (S) = E_Procedure
6964
                    or else Ekind (S) = E_Function)
6965
              and then Has_Completion (S)
6966
            then
6967
               Full_Vis := True;
6968
            else
6969
               Full_Vis := False;
6970
            end if;
6971
         else
6972
            Full_Vis := True;
6973
         end if;
6974
      end loop;
6975
 
6976
      if SS_Last >= Scope_Stack.First
6977
        and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
6978
        and then Handle_Use
6979
      then
6980
         Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
6981
      end if;
6982
   end Restore_Scope_Stack;
6983
 
6984
   ----------------------
6985
   -- Save_Scope_Stack --
6986
   ----------------------
6987
 
6988
   procedure Save_Scope_Stack (Handle_Use : Boolean := True) is
6989
      E       : Entity_Id;
6990
      S       : Entity_Id;
6991
      SS_Last : constant Int := Scope_Stack.Last;
6992
 
6993
   begin
6994
      if SS_Last >= Scope_Stack.First
6995
        and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
6996
      then
6997
         if Handle_Use then
6998
            End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
6999
         end if;
7000
 
7001
         --  If the call is from within a compilation unit, as when called from
7002
         --  Rtsfind, make current entries in scope stack invisible while we
7003
         --  analyze the new unit.
7004
 
7005
         for J in reverse 0 .. SS_Last loop
7006
            exit when  Scope_Stack.Table (J).Entity = Standard_Standard
7007
               or else No (Scope_Stack.Table (J).Entity);
7008
 
7009
            S := Scope_Stack.Table (J).Entity;
7010
            Set_Is_Immediately_Visible (S, False);
7011
 
7012
            E := First_Entity (S);
7013
            while Present (E) loop
7014
               Set_Is_Immediately_Visible (E, False);
7015
               Next_Entity (E);
7016
            end loop;
7017
         end loop;
7018
 
7019
      end if;
7020
   end Save_Scope_Stack;
7021
 
7022
   -------------
7023
   -- Set_Use --
7024
   -------------
7025
 
7026
   procedure Set_Use (L : List_Id) is
7027
      Decl      : Node_Id;
7028
      Pack_Name : Node_Id;
7029
      Pack      : Entity_Id;
7030
      Id        : Entity_Id;
7031
 
7032
   begin
7033
      if Present (L) then
7034
         Decl := First (L);
7035
         while Present (Decl) loop
7036
            if Nkind (Decl) = N_Use_Package_Clause then
7037
               Chain_Use_Clause (Decl);
7038
 
7039
               Pack_Name := First (Names (Decl));
7040
               while Present (Pack_Name) loop
7041
                  Pack := Entity (Pack_Name);
7042
 
7043
                  if Ekind (Pack) = E_Package
7044
                    and then Applicable_Use (Pack_Name)
7045
                  then
7046
                     Use_One_Package (Pack, Decl);
7047
                  end if;
7048
 
7049
                  Next (Pack_Name);
7050
               end loop;
7051
 
7052
            elsif Nkind (Decl) = N_Use_Type_Clause  then
7053
               Chain_Use_Clause (Decl);
7054
 
7055
               Id := First (Subtype_Marks (Decl));
7056
               while Present (Id) loop
7057
                  if Entity (Id) /= Any_Type then
7058
                     Use_One_Type (Id);
7059
                  end if;
7060
 
7061
                  Next (Id);
7062
               end loop;
7063
            end if;
7064
 
7065
            Next (Decl);
7066
         end loop;
7067
      end if;
7068
   end Set_Use;
7069
 
7070
   ---------------------
7071
   -- Use_One_Package --
7072
   ---------------------
7073
 
7074
   procedure Use_One_Package (P : Entity_Id; N : Node_Id) is
7075
      Id               : Entity_Id;
7076
      Prev             : Entity_Id;
7077
      Current_Instance : Entity_Id := Empty;
7078
      Real_P           : Entity_Id;
7079
      Private_With_OK  : Boolean   := False;
7080
 
7081
   begin
7082
      if Ekind (P) /= E_Package then
7083
         return;
7084
      end if;
7085
 
7086
      Set_In_Use (P);
7087
      Set_Current_Use_Clause (P, N);
7088
 
7089
      --  Ada 2005 (AI-50217): Check restriction
7090
 
7091
      if From_With_Type (P) then
7092
         Error_Msg_N ("limited withed package cannot appear in use clause", N);
7093
      end if;
7094
 
7095
      --  Find enclosing instance, if any
7096
 
7097
      if In_Instance then
7098
         Current_Instance := Current_Scope;
7099
         while not Is_Generic_Instance (Current_Instance) loop
7100
            Current_Instance := Scope (Current_Instance);
7101
         end loop;
7102
 
7103
         if No (Hidden_By_Use_Clause (N)) then
7104
            Set_Hidden_By_Use_Clause (N, New_Elmt_List);
7105
         end if;
7106
      end if;
7107
 
7108
      --  If unit is a package renaming, indicate that the renamed
7109
      --  package is also in use (the flags on both entities must
7110
      --  remain consistent, and a subsequent use of either of them
7111
      --  should be recognized as redundant).
7112
 
7113
      if Present (Renamed_Object (P)) then
7114
         Set_In_Use (Renamed_Object (P));
7115
         Set_Current_Use_Clause (Renamed_Object (P), N);
7116
         Real_P := Renamed_Object (P);
7117
      else
7118
         Real_P := P;
7119
      end if;
7120
 
7121
      --  Ada 2005 (AI-262): Check the use_clause of a private withed package
7122
      --  found in the private part of a package specification
7123
 
7124
      if In_Private_Part (Current_Scope)
7125
        and then Has_Private_With (P)
7126
        and then Is_Child_Unit (Current_Scope)
7127
        and then Is_Child_Unit (P)
7128
        and then Is_Ancestor_Package (Scope (Current_Scope), P)
7129
      then
7130
         Private_With_OK := True;
7131
      end if;
7132
 
7133
      --  Loop through entities in one package making them potentially
7134
      --  use-visible.
7135
 
7136
      Id := First_Entity (P);
7137
      while Present (Id)
7138
        and then (Id /= First_Private_Entity (P)
7139
                    or else Private_With_OK) -- Ada 2005 (AI-262)
7140
      loop
7141
         Prev := Current_Entity (Id);
7142
         while Present (Prev) loop
7143
            if Is_Immediately_Visible (Prev)
7144
              and then (not Is_Overloadable (Prev)
7145
                         or else not Is_Overloadable (Id)
7146
                         or else (Type_Conformant (Id, Prev)))
7147
            then
7148
               if No (Current_Instance) then
7149
 
7150
                  --  Potentially use-visible entity remains hidden
7151
 
7152
                  goto Next_Usable_Entity;
7153
 
7154
               --  A use clause within an instance hides outer global entities,
7155
               --  which are not used to resolve local entities in the
7156
               --  instance. Note that the predefined entities in Standard
7157
               --  could not have been hidden in the generic by a use clause,
7158
               --  and therefore remain visible. Other compilation units whose
7159
               --  entities appear in Standard must be hidden in an instance.
7160
 
7161
               --  To determine whether an entity is external to the instance
7162
               --  we compare the scope depth of its scope with that of the
7163
               --  current instance. However, a generic actual of a subprogram
7164
               --  instance is declared in the wrapper package but will not be
7165
               --  hidden by a use-visible entity. Similarly, a generic actual
7166
               --  will not be hidden by an entity declared in another generic
7167
               --  actual, which can only have been use-visible in the generic.
7168
               --  Is this condition complete, and can the following complex
7169
               --  test be simplified ???
7170
 
7171
               --  If Id is called Standard, the predefined package with the
7172
               --  same name is in the homonym chain. It has to be ignored
7173
               --  because it has no defined scope (being the only entity in
7174
               --  the system with this mandated behavior).
7175
 
7176
               elsif not Is_Hidden (Id)
7177
                 and then Present (Scope (Prev))
7178
                 and then not Is_Wrapper_Package (Scope (Prev))
7179
                 and then Scope_Depth (Scope (Prev)) <
7180
                          Scope_Depth (Current_Instance)
7181
                 and then (Scope (Prev) /= Standard_Standard
7182
                            or else Sloc (Prev) > Standard_Location)
7183
               then
7184
                  if Ekind (Prev) = E_Package
7185
                    and then Present (Associated_Formal_Package (Prev))
7186
                    and then Present (Associated_Formal_Package (P))
7187
                  then
7188
                     null;
7189
 
7190
                  else
7191
                     Set_Is_Potentially_Use_Visible (Id);
7192
                     Set_Is_Immediately_Visible (Prev, False);
7193
                     Append_Elmt (Prev, Hidden_By_Use_Clause (N));
7194
                  end if;
7195
               end if;
7196
 
7197
            --  A user-defined operator is not use-visible if the predefined
7198
            --  operator for the type is immediately visible, which is the case
7199
            --  if the type of the operand is in an open scope. This does not
7200
            --  apply to user-defined operators that have operands of different
7201
            --  types, because the predefined mixed mode operations (multiply
7202
            --  and divide) apply to universal types and do not hide anything.
7203
 
7204
            elsif Ekind (Prev) = E_Operator
7205
              and then Operator_Matches_Spec (Prev, Id)
7206
              and then In_Open_Scopes
7207
               (Scope (Base_Type (Etype (First_Formal (Id)))))
7208
              and then (No (Next_Formal (First_Formal (Id)))
7209
                         or else Etype (First_Formal (Id))
7210
                           = Etype (Next_Formal (First_Formal (Id)))
7211
                         or else Chars (Prev) = Name_Op_Expon)
7212
            then
7213
               goto Next_Usable_Entity;
7214
 
7215
            --  In an instance, two homonyms may become use_visible through the
7216
            --  actuals of distinct formal packages. In the generic, only the
7217
            --  current one would have been visible, so make the other one
7218
            --  not use_visible.
7219
 
7220
            elsif Present (Current_Instance)
7221
              and then Is_Potentially_Use_Visible (Prev)
7222
              and then not Is_Overloadable (Prev)
7223
              and then Scope (Id) /= Scope (Prev)
7224
              and then Used_As_Generic_Actual (Scope (Prev))
7225
              and then Used_As_Generic_Actual (Scope (Id))
7226
              and then List_Containing (Current_Use_Clause (Scope (Prev))) /=
7227
                       List_Containing (Current_Use_Clause (Scope (Id)))
7228
            then
7229
               Set_Is_Potentially_Use_Visible (Prev, False);
7230
               Append_Elmt (Prev, Hidden_By_Use_Clause (N));
7231
            end if;
7232
 
7233
            Prev := Homonym (Prev);
7234
         end loop;
7235
 
7236
         --  On exit, we know entity is not hidden, unless it is private
7237
 
7238
         if not Is_Hidden (Id)
7239
           and then ((not Is_Child_Unit (Id))
7240
                       or else Is_Visible_Child_Unit (Id))
7241
         then
7242
            Set_Is_Potentially_Use_Visible (Id);
7243
 
7244
            if Is_Private_Type (Id)
7245
              and then Present (Full_View (Id))
7246
            then
7247
               Set_Is_Potentially_Use_Visible (Full_View (Id));
7248
            end if;
7249
         end if;
7250
 
7251
         <<Next_Usable_Entity>>
7252
            Next_Entity (Id);
7253
      end loop;
7254
 
7255
      --  Child units are also made use-visible by a use clause, but they may
7256
      --  appear after all visible declarations in the parent entity list.
7257
 
7258
      while Present (Id) loop
7259
         if Is_Child_Unit (Id)
7260
           and then Is_Visible_Child_Unit (Id)
7261
         then
7262
            Set_Is_Potentially_Use_Visible (Id);
7263
         end if;
7264
 
7265
         Next_Entity (Id);
7266
      end loop;
7267
 
7268
      if Chars (Real_P) = Name_System
7269
        and then Scope (Real_P) = Standard_Standard
7270
        and then Present_System_Aux (N)
7271
      then
7272
         Use_One_Package (System_Aux_Id, N);
7273
      end if;
7274
 
7275
   end Use_One_Package;
7276
 
7277
   ------------------
7278
   -- Use_One_Type --
7279
   ------------------
7280
 
7281
   procedure Use_One_Type (Id : Node_Id) is
7282
      Elmt          : Elmt_Id;
7283
      Is_Known_Used : Boolean;
7284
      Op_List       : Elist_Id;
7285
      T             : Entity_Id;
7286
 
7287
      function Spec_Reloaded_For_Body return Boolean;
7288
      --  Determine whether the compilation unit is a package body and the use
7289
      --  type clause is in the spec of the same package. Even though the spec
7290
      --  was analyzed first, its context is reloaded when analysing the body.
7291
 
7292
      ----------------------------
7293
      -- Spec_Reloaded_For_Body --
7294
      ----------------------------
7295
 
7296
      function Spec_Reloaded_For_Body return Boolean is
7297
      begin
7298
         if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
7299
            declare
7300
               Spec : constant Node_Id :=
7301
                        Parent (List_Containing (Parent (Id)));
7302
            begin
7303
               return
7304
                 Nkind (Spec) = N_Package_Specification
7305
                   and then Corresponding_Body (Parent (Spec)) =
7306
                              Cunit_Entity (Current_Sem_Unit);
7307
            end;
7308
         end if;
7309
 
7310
         return False;
7311
      end Spec_Reloaded_For_Body;
7312
 
7313
   --  Start of processing for Use_One_Type;
7314
 
7315
   begin
7316
      --  It is the type determined by the subtype mark (8.4(8)) whose
7317
      --  operations become potentially use-visible.
7318
 
7319
      T := Base_Type (Entity (Id));
7320
 
7321
      --  Either the type itself is used, the package where it is declared
7322
      --  is in use or the entity is declared in the current package, thus
7323
      --  use-visible.
7324
 
7325
      Is_Known_Used :=
7326
        In_Use (T)
7327
          or else In_Use (Scope (T))
7328
          or else Scope (T) = Current_Scope;
7329
 
7330
      Set_Redundant_Use (Id,
7331
        Is_Known_Used or else Is_Potentially_Use_Visible (T));
7332
 
7333
      if Ekind (T) = E_Incomplete_Type then
7334
         Error_Msg_N ("premature usage of incomplete type", Id);
7335
 
7336
      elsif In_Open_Scopes (Scope (T)) then
7337
         null;
7338
 
7339
      --  A limited view cannot appear in a use_type clause. However, an access
7340
      --  type whose designated type is limited has the flag but is not itself
7341
      --  a limited view unless we only have a limited view of its enclosing
7342
      --  package.
7343
 
7344
      elsif From_With_Type (T)
7345
        and then From_With_Type (Scope (T))
7346
      then
7347
         Error_Msg_N
7348
           ("incomplete type from limited view "
7349
             & "cannot appear in use clause", Id);
7350
 
7351
      --  If the subtype mark designates a subtype in a different package,
7352
      --  we have to check that the parent type is visible, otherwise the
7353
      --  use type clause is a noop. Not clear how to do that???
7354
 
7355
      elsif not Redundant_Use (Id) then
7356
         Set_In_Use (T);
7357
 
7358
         --  If T is tagged, primitive operators on class-wide operands
7359
         --  are also available.
7360
 
7361
         if Is_Tagged_Type (T) then
7362
            Set_In_Use (Class_Wide_Type (T));
7363
         end if;
7364
 
7365
         Set_Current_Use_Clause (T, Parent (Id));
7366
         Op_List := Collect_Primitive_Operations (T);
7367
 
7368
         Elmt := First_Elmt (Op_List);
7369
         while Present (Elmt) loop
7370
            if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol
7371
                 or else Chars (Node (Elmt)) in Any_Operator_Name)
7372
              and then not Is_Hidden (Node (Elmt))
7373
            then
7374
               Set_Is_Potentially_Use_Visible (Node (Elmt));
7375
            end if;
7376
 
7377
            Next_Elmt (Elmt);
7378
         end loop;
7379
      end if;
7380
 
7381
      --  If warning on redundant constructs, check for unnecessary WITH
7382
 
7383
      if Warn_On_Redundant_Constructs
7384
        and then Is_Known_Used
7385
 
7386
         --                     with P;         with P; use P;
7387
         --    package P is     package X is    package body X is
7388
         --       type T ...       use P.T;
7389
 
7390
         --  The compilation unit is the body of X. GNAT first compiles the
7391
         --  spec of X, then proceeds to the body. At that point P is marked
7392
         --  as use visible. The analysis then reinstalls the spec along with
7393
         --  its context. The use clause P.T is now recognized as redundant,
7394
         --  but in the wrong context. Do not emit a warning in such cases.
7395
         --  Do not emit a warning either if we are in an instance, there is
7396
         --  no redundancy between an outer use_clause and one that appears
7397
         --  within the generic.
7398
 
7399
        and then not Spec_Reloaded_For_Body
7400
        and then not In_Instance
7401
      then
7402
         --  The type already has a use clause
7403
 
7404
         if In_Use (T) then
7405
 
7406
            --  Case where we know the current use clause for the type
7407
 
7408
            if Present (Current_Use_Clause (T)) then
7409
               Use_Clause_Known : declare
7410
                  Clause1 : constant Node_Id := Parent (Id);
7411
                  Clause2 : constant Node_Id := Current_Use_Clause (T);
7412
                  Ent1    : Entity_Id;
7413
                  Ent2    : Entity_Id;
7414
                  Err_No  : Node_Id;
7415
                  Unit1   : Node_Id;
7416
                  Unit2   : Node_Id;
7417
 
7418
                  function Entity_Of_Unit (U : Node_Id) return Entity_Id;
7419
                  --  Return the appropriate entity for determining which unit
7420
                  --  has a deeper scope: the defining entity for U, unless U
7421
                  --  is a package instance, in which case we retrieve the
7422
                  --  entity of the instance spec.
7423
 
7424
                  --------------------
7425
                  -- Entity_Of_Unit --
7426
                  --------------------
7427
 
7428
                  function Entity_Of_Unit (U : Node_Id) return Entity_Id is
7429
                  begin
7430
                     if Nkind (U) =  N_Package_Instantiation
7431
                       and then Analyzed (U)
7432
                     then
7433
                        return Defining_Entity (Instance_Spec (U));
7434
                     else
7435
                        return Defining_Entity (U);
7436
                     end if;
7437
                  end Entity_Of_Unit;
7438
 
7439
               --  Start of processing for Use_Clause_Known
7440
 
7441
               begin
7442
                  --  If both current use type clause and the use type clause
7443
                  --  for the type are at the compilation unit level, one of
7444
                  --  the units must be an ancestor of the other, and the
7445
                  --  warning belongs on the descendant.
7446
 
7447
                  if Nkind (Parent (Clause1)) = N_Compilation_Unit
7448
                       and then
7449
                     Nkind (Parent (Clause2)) = N_Compilation_Unit
7450
                  then
7451
 
7452
                     --  If the unit is a subprogram body that acts as spec,
7453
                     --  the context clause is shared with the constructed
7454
                     --  subprogram spec. Clearly there is no redundancy.
7455
 
7456
                     if Clause1 = Clause2 then
7457
                        return;
7458
                     end if;
7459
 
7460
                     Unit1 := Unit (Parent (Clause1));
7461
                     Unit2 := Unit (Parent (Clause2));
7462
 
7463
                     --  If both clauses are on same unit, or one is the body
7464
                     --  of the other, or one of them is in a subunit, report
7465
                     --  redundancy on the later one.
7466
 
7467
                     if Unit1 = Unit2 then
7468
                        Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
7469
                        Error_Msg_NE
7470
                          ("& is already use-visible through previous "
7471
                           & "use_type_clause #?", Clause1, T);
7472
                        return;
7473
 
7474
                     elsif Nkind (Unit1) = N_Subunit then
7475
                        Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
7476
                        Error_Msg_NE
7477
                          ("& is already use-visible through previous "
7478
                           & "use_type_clause #?", Clause1, T);
7479
                        return;
7480
 
7481
                     elsif Nkind_In (Unit2, N_Package_Body, N_Subprogram_Body)
7482
                       and then Nkind (Unit1) /= Nkind (Unit2)
7483
                       and then Nkind (Unit1) /= N_Subunit
7484
                     then
7485
                        Error_Msg_Sloc := Sloc (Clause1);
7486
                        Error_Msg_NE
7487
                          ("& is already use-visible through previous "
7488
                           & "use_type_clause #?", Current_Use_Clause (T), T);
7489
                        return;
7490
                     end if;
7491
 
7492
                     --  There is a redundant use type clause in a child unit.
7493
                     --  Determine which of the units is more deeply nested.
7494
                     --  If a unit is a package instance, retrieve the entity
7495
                     --  and its scope from the instance spec.
7496
 
7497
                     Ent1 := Entity_Of_Unit (Unit1);
7498
                     Ent2 := Entity_Of_Unit (Unit2);
7499
 
7500
                     if Scope (Ent2) = Standard_Standard  then
7501
                        Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
7502
                        Err_No := Clause1;
7503
 
7504
                     elsif Scope (Ent1) = Standard_Standard then
7505
                        Error_Msg_Sloc := Sloc (Id);
7506
                        Err_No := Clause2;
7507
 
7508
                     --  If both units are child units, we determine which one
7509
                     --  is the descendant by the scope distance to the
7510
                     --  ultimate parent unit.
7511
 
7512
                     else
7513
                        declare
7514
                           S1, S2 : Entity_Id;
7515
 
7516
                        begin
7517
                           S1 := Scope (Ent1);
7518
                           S2 := Scope (Ent2);
7519
                           while S1 /= Standard_Standard
7520
                                   and then
7521
                                 S2 /= Standard_Standard
7522
                           loop
7523
                              S1 := Scope (S1);
7524
                              S2 := Scope (S2);
7525
                           end loop;
7526
 
7527
                           if S1 = Standard_Standard then
7528
                              Error_Msg_Sloc := Sloc (Id);
7529
                              Err_No := Clause2;
7530
                           else
7531
                              Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
7532
                              Err_No := Clause1;
7533
                           end if;
7534
                        end;
7535
                     end if;
7536
 
7537
                     Error_Msg_NE
7538
                       ("& is already use-visible through previous "
7539
                        & "use_type_clause #?", Err_No, Id);
7540
 
7541
                  --  Case where current use type clause and the use type
7542
                  --  clause for the type are not both at the compilation unit
7543
                  --  level. In this case we don't have location information.
7544
 
7545
                  else
7546
                     Error_Msg_NE
7547
                       ("& is already use-visible through previous "
7548
                        & "use type clause?", Id, T);
7549
                  end if;
7550
               end Use_Clause_Known;
7551
 
7552
            --  Here if Current_Use_Clause is not set for T, another case
7553
            --  where we do not have the location information available.
7554
 
7555
            else
7556
               Error_Msg_NE
7557
                 ("& is already use-visible through previous "
7558
                  & "use type clause?", Id, T);
7559
            end if;
7560
 
7561
         --  The package where T is declared is already used
7562
 
7563
         elsif In_Use (Scope (T)) then
7564
            Error_Msg_Sloc := Sloc (Current_Use_Clause (Scope (T)));
7565
            Error_Msg_NE
7566
              ("& is already use-visible through package use clause #?",
7567
               Id, T);
7568
 
7569
         --  The current scope is the package where T is declared
7570
 
7571
         else
7572
            Error_Msg_Node_2 := Scope (T);
7573
            Error_Msg_NE
7574
              ("& is already use-visible inside package &?", Id, T);
7575
         end if;
7576
      end if;
7577
   end Use_One_Type;
7578
 
7579
   ----------------
7580
   -- Write_Info --
7581
   ----------------
7582
 
7583
   procedure Write_Info is
7584
      Id : Entity_Id := First_Entity (Current_Scope);
7585
 
7586
   begin
7587
      --  No point in dumping standard entities
7588
 
7589
      if Current_Scope = Standard_Standard then
7590
         return;
7591
      end if;
7592
 
7593
      Write_Str ("========================================================");
7594
      Write_Eol;
7595
      Write_Str ("        Defined Entities in ");
7596
      Write_Name (Chars (Current_Scope));
7597
      Write_Eol;
7598
      Write_Str ("========================================================");
7599
      Write_Eol;
7600
 
7601
      if No (Id) then
7602
         Write_Str ("-- none --");
7603
         Write_Eol;
7604
 
7605
      else
7606
         while Present (Id) loop
7607
            Write_Entity_Info (Id, " ");
7608
            Next_Entity (Id);
7609
         end loop;
7610
      end if;
7611
 
7612
      if Scope (Current_Scope) = Standard_Standard then
7613
 
7614
         --  Print information on the current unit itself
7615
 
7616
         Write_Entity_Info (Current_Scope, " ");
7617
      end if;
7618
 
7619
      Write_Eol;
7620
   end Write_Info;
7621
 
7622
   -----------------
7623
   -- Write_Scopes --
7624
   -----------------
7625
 
7626
   procedure Write_Scopes is
7627
      S : Entity_Id;
7628
   begin
7629
      for J in reverse 1 .. Scope_Stack.Last loop
7630
         S :=  Scope_Stack.Table (J).Entity;
7631
         Write_Int (Int (S));
7632
         Write_Str (" === ");
7633
         Write_Name (Chars (S));
7634
         Write_Eol;
7635
      end loop;
7636
   end Write_Scopes;
7637
 
7638
end Sem_Ch8;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.