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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_ch8.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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