gcc/ada/sem_ch8.adb

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