gcc/ada/sem_ch12.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ C H 1 2                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Expander; use Expander;
  32 with Fname;    use Fname;
  33 with Fname.UF; use Fname.UF;
  34 with Freeze;   use Freeze;
  35 with Hostparm;
  36 with Inline;   use Inline;
  37 with Lib;      use Lib;
  38 with Lib.Load; use Lib.Load;
  39 with Lib.Xref; use Lib.Xref;
  40 with Nlists;   use Nlists;
  41 with Nmake;    use Nmake;
  42 with Opt;      use Opt;
  43 with Rident;   use Rident;
  44 with Restrict; use Restrict;
  45 with Rtsfind;  use Rtsfind;
  46 with Sem;      use Sem;
  47 with Sem_Cat;  use Sem_Cat;
  48 with Sem_Ch3;  use Sem_Ch3;
  49 with Sem_Ch6;  use Sem_Ch6;
  50 with Sem_Ch7;  use Sem_Ch7;
  51 with Sem_Ch8;  use Sem_Ch8;
  52 with Sem_Ch10; use Sem_Ch10;
  53 with Sem_Ch13; use Sem_Ch13;
  54 with Sem_Elab; use Sem_Elab;
  55 with Sem_Elim; use Sem_Elim;
  56 with Sem_Eval; use Sem_Eval;
  57 with Sem_Res;  use Sem_Res;
  58 with Sem_Type; use Sem_Type;
  59 with Sem_Util; use Sem_Util;
  60 with Sem_Warn; use Sem_Warn;
  61 with Stand;    use Stand;
  62 with Sinfo;    use Sinfo;
  63 with Sinfo.CN; use Sinfo.CN;
  64 with Sinput;   use Sinput;
  65 with Sinput.L; use Sinput.L;
  66 with Snames;   use Snames;
  67 with Stringt;  use Stringt;
  68 with Uname;    use Uname;
  69 with Table;
  70 with Tbuild;   use Tbuild;
  71 with Uintp;    use Uintp;
  72 with Urealp;   use Urealp;
  73
  74 with GNAT.HTable;
  75
  76 package body Sem_Ch12 is
  77
  78    ----------------------------------------------------------
  79    -- Implementation of Generic Analysis and Instantiation --
  80    -----------------------------------------------------------
  81
  82    --  GNAT implements generics by macro expansion. No attempt is made to
  83    --  share generic instantiations (for now). Analysis of a generic definition
  84    --  does not perform any expansion action, but the expander must be called
  85    --  on the tree for each instantiation, because the expansion may of course
  86    --  depend on the generic actuals. All of this is best achieved as follows:
  87    --
  88    --  a) Semantic analysis of a generic unit is performed on a copy of the
  89    --  tree for the generic unit. All tree modifications that follow analysis
  90    --  do not affect the original tree. Links are kept between the original
  91    --  tree and the copy, in order to recognize non-local references within
  92    --  the generic, and propagate them to each instance (recall that name
  93    --  resolution is done on the generic declaration: generics are not really
  94    --  macros!). This is summarized in the following diagram:
  95    --
  96    --              .-----------.               .----------.
  97    --              |  semantic |<--------------|  generic |
  98    --              |    copy   |               |    unit  |
  99    --              |           |==============>|          |
 100    --              |___________|    global     |__________|
 101    --                             references     |   |  |
 102    --                                            |   |  |
 103    --                                          .-----|--|.
 104    --                                          |  .-----|---.
 105    --                                          |  |  .----------.
 106    --                                          |  |  |  generic |
 107    --                                          |__|  |          |
 108    --                                             |__| instance |
 109    --                                                |__________|
 110    --
 111    --  b) Each instantiation copies the original tree, and inserts into it a
 112    --  series of declarations that describe the mapping between generic formals
 113    --  and actuals. For example, a generic In OUT parameter is an object
 114    --  renaming of the corresponing actual, etc. Generic IN parameters are
 115    --  constant declarations.
 116    --
 117    --  c) In order to give the right visibility for these renamings, we use
 118    --  a different scheme for package and subprogram instantiations. For
 119    --  packages, the list of renamings is inserted into the package
 120    --  specification, before the visible declarations of the package. The
 121    --  renamings are analyzed before any of the text of the instance, and are
 122    --  thus visible at the right place. Furthermore, outside of the instance,
 123    --  the generic parameters are visible and denote their corresponding
 124    --  actuals.
 125
 126    --  For subprograms, we create a container package to hold the renamings
 127    --  and the subprogram instance itself. Analysis of the package makes the
 128    --  renaming declarations visible to the subprogram. After analyzing the
 129    --  package, the defining entity for the subprogram is touched-up so that
 130    --  it appears declared in the current scope, and not inside the container
 131    --  package.
 132
 133    --  If the instantiation is a compilation unit, the container package is
 134    --  given the same name as the subprogram instance. This ensures that
 135    --  the elaboration procedure called by the binder, using the compilation
 136    --  unit name, calls in fact the elaboration procedure for the package.
 137
 138    --  Not surprisingly, private types complicate this approach. By saving in
 139    --  the original generic object the non-local references, we guarantee that
 140    --  the proper entities are referenced at the point of instantiation.
 141    --  However, for private types, this by itself does not insure that the
 142    --  proper VIEW of the entity is used (the full type may be visible at the
 143    --  point of generic definition, but not at instantiation, or vice-versa).
 144    --  In  order to reference the proper view, we special-case any reference
 145    --  to private types in the generic object, by saving both views, one in
 146    --  the generic and one in the semantic copy. At time of instantiation, we
 147    --  check whether the two views are consistent, and exchange declarations if
 148    --  necessary, in order to restore the correct visibility. Similarly, if
 149    --  the instance view is private when the generic view was not, we perform
 150    --  the exchange. After completing the instantiation, we restore the
 151    --  current visibility. The flag Has_Private_View marks identifiers in the
 152    --  the generic unit that require checking.
 153
 154    --  Visibility within nested generic units requires special handling.
 155    --  Consider the following scheme:
 156    --
 157    --  type Global is ...         --  outside of generic unit.
 158    --  generic ...
 159    --  package Outer is
 160    --     ...
 161    --     type Semi_Global is ... --  global to inner.
 162    --
 163    --     generic ...                                         -- 1
 164    --     procedure inner (X1 : Global;  X2 : Semi_Global);
 165    --
 166    --     procedure in2 is new inner (...);                   -- 4
 167    --  end Outer;
 168
 169    --  package New_Outer is new Outer (...);                  -- 2
 170    --  procedure New_Inner is new New_Outer.Inner (...);      -- 3
 171
 172    --  The semantic analysis of Outer captures all occurrences of Global.
 173    --  The semantic analysis of Inner (at 1) captures both occurrences of
 174    --  Global and Semi_Global.
 175
 176    --  At point 2 (instantiation of Outer), we also produce a generic copy
 177    --  of Inner, even though Inner is, at that point, not being instantiated.
 178    --  (This is just part of the semantic analysis of New_Outer).
 179
 180    --  Critically, references to Global within Inner must be preserved, while
 181    --  references to Semi_Global should not preserved, because they must now
 182    --  resolve to an entity within New_Outer. To distinguish between these, we
 183    --  use a global variable, Current_Instantiated_Parent, which is set when
 184    --  performing a generic copy during instantiation (at 2). This variable is
 185    --  used when performing a generic copy that is not an instantiation, but
 186    --  that is nested within one, as the occurrence of 1 within 2. The analysis
 187    --  of a nested generic only preserves references that are global to the
 188    --  enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
 189    --  determine whether a reference is external to the given parent.
 190
 191    --  The instantiation at point 3 requires no special treatment. The method
 192    --  works as well for further nestings of generic units, but of course the
 193    --  variable Current_Instantiated_Parent must be stacked because nested
 194    --  instantiations can occur, e.g. the occurrence of 4 within 2.
 195
 196    --  The instantiation of package and subprogram bodies is handled in a
 197    --  similar manner, except that it is delayed until after semantic
 198    --  analysis is complete. In this fashion complex cross-dependencies
 199    --  between several package declarations and bodies containing generics
 200    --  can be compiled which otherwise would diagnose spurious circularities.
 201
 202    --  For example, it is possible to compile two packages A and B that
 203    --  have the following structure:
 204
 205    --    package A is                         package B is
 206    --       generic ...                          generic ...
 207    --       package G_A is                       package G_B is
 208
 209    --    with B;                              with A;
 210    --    package body A is                    package body B is
 211    --       package N_B is new G_B (..)          package N_A is new G_A (..)
 212
 213    --  The table Pending_Instantiations in package Inline is used to keep
 214    --  track of body instantiations that are delayed in this manner. Inline
 215    --  handles the actual calls to do the body instantiations. This activity
 216    --  is part of Inline, since the processing occurs at the same point, and
 217    --  for essentially the same reason, as the handling of inlined routines.
 218
 219    ----------------------------------------------
 220    -- Detection of Instantiation Circularities --
 221    ----------------------------------------------
 222
 223    --  If we have a chain of instantiations that is circular, this is a
 224    --  static error which must be detected at compile time. The detection
 225    --  of these circularities is carried out at the point that we insert
 226    --  a generic instance spec or body. If there is a circularity, then
 227    --  the analysis of the offending spec or body will eventually result
 228    --  in trying to load the same unit again, and we detect this problem
 229    --  as we analyze the package instantiation for the second time.
 230
 231    --  At least in some cases after we have detected the circularity, we
 232    --  get into trouble if we try to keep going. The following flag is
 233    --  set if a circularity is detected, and used to abandon compilation
 234    --  after the messages have been posted.
 235
 236    Circularity_Detected : Boolean := False;
 237    --  This should really be reset on encountering a new main unit, but in
 238    --  practice we are not using multiple main units so it is not critical.
 239
 240    -----------------------
 241    -- Local subprograms --
 242    -----------------------
 243
 244    procedure Abandon_Instantiation (N : Node_Id);
 245    pragma No_Return (Abandon_Instantiation);
 246    --  Posts an error message "instantiation abandoned" at the indicated
 247    --  node and then raises the exception Instantiation_Error to do it.
 248
 249    procedure Analyze_Formal_Array_Type
 250      (T   : in out Entity_Id;
 251       Def : Node_Id);
 252    --  A formal array type is treated like an array type declaration, and
 253    --  invokes Array_Type_Declaration (sem_ch3) whose first parameter is
 254    --  in-out, because in the case of an anonymous type the entity is
 255    --  actually created in the procedure.
 256
 257    --  The following procedures treat other kinds of formal parameters.
 258
 259    procedure Analyze_Formal_Derived_Type
 260      (N   : Node_Id;
 261       T   : Entity_Id;
 262       Def : Node_Id);
 263
 264    --  All the following need comments???
 265
 266    procedure Analyze_Formal_Decimal_Fixed_Point_Type
 267                                                 (T : Entity_Id; Def : Node_Id);
 268    procedure Analyze_Formal_Discrete_Type       (T : Entity_Id; Def : Node_Id);
 269    procedure Analyze_Formal_Floating_Type       (T : Entity_Id; Def : Node_Id);
 270    procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id);
 271    procedure Analyze_Formal_Modular_Type        (T : Entity_Id; Def : Node_Id);
 272    procedure Analyze_Formal_Ordinary_Fixed_Point_Type
 273                                                 (T : Entity_Id; Def : Node_Id);
 274
 275    procedure Analyze_Formal_Private_Type
 276      (N   : Node_Id;
 277       T   : Entity_Id;
 278       Def : Node_Id);
 279    --  This needs comments???
 280
 281    procedure Analyze_Generic_Formal_Part (N : Node_Id);
 282
 283    procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
 284    --  This needs comments ???
 285
 286    function Analyze_Associations
 287      (I_Node  : Node_Id;
 288       Formals : List_Id;
 289       F_Copy  : List_Id)
 290       return    List_Id;
 291    --  At instantiation time, build the list of associations between formals
 292    --  and actuals. Each association becomes a renaming declaration for the
 293    --  formal entity. F_Copy is the analyzed list of formals in the generic
 294    --  copy. It is used to apply legality checks to the actuals. I_Node is the
 295    --  instantiation node itself.
 296
 297    procedure Analyze_Subprogram_Instantiation
 298      (N : Node_Id;
 299       K : Entity_Kind);
 300
 301    procedure Build_Instance_Compilation_Unit_Nodes
 302      (N        : Node_Id;
 303       Act_Body : Node_Id;
 304       Act_Decl : Node_Id);
 305    --  This procedure is used in the case where the generic instance of a
 306    --  subprogram body or package body is a library unit. In this case, the
 307    --  original library unit node for the generic instantiation must be
 308    --  replaced by the resulting generic body, and a link made to a new
 309    --  compilation unit node for the generic declaration. The argument N is
 310    --  the original generic instantiation. Act_Body and Act_Decl are the body
 311    --  and declaration of the instance (either package body and declaration
 312    --  nodes or subprogram body and declaration nodes depending on the case).
 313    --  On return, the node N has been rewritten with the actual body.
 314
 315    procedure Check_Formal_Packages (P_Id : Entity_Id);
 316    --  Apply the following to all formal packages in generic associations.
 317
 318    procedure Check_Formal_Package_Instance
 319      (Formal_Pack : Entity_Id;
 320       Actual_Pack : Entity_Id);
 321    --  Verify that the actuals of the actual instance match the actuals of
 322    --  the template for a formal package that is not declared with a box.
 323
 324    procedure Check_Forward_Instantiation (Decl : Node_Id);
 325    --  If the generic is a local entity and the corresponding body has not
 326    --  been seen yet, flag enclosing packages to indicate that it will be
 327    --  elaborated after the generic body. Subprograms declared in the same
 328    --  package cannot be inlined by the front-end because front-end inlining
 329    --  requires a strict linear order of elaboration.
 330
 331    procedure Check_Hidden_Child_Unit
 332      (N           : Node_Id;
 333       Gen_Unit    : Entity_Id;
 334       Act_Decl_Id : Entity_Id);
 335    --  If the generic unit is an implicit child instance within a parent
 336    --  instance, we need to make an explicit test that it is not hidden by
 337    --  a child instance of the same name and parent.
 338
 339    procedure Check_Private_View (N : Node_Id);
 340    --  Check whether the type of a generic entity has a different view between
 341    --  the point of generic analysis and the point of instantiation. If the
 342    --  view has changed, then at the point of instantiation we restore the
 343    --  correct view to perform semantic analysis of the instance, and reset
 344    --  the current view after instantiation. The processing is driven by the
 345    --  current private status of the type of the node, and Has_Private_View,
 346    --  a flag that is set at the point of generic compilation. If view and
 347    --  flag are inconsistent then the type is updated appropriately.
 348
 349    procedure Check_Generic_Actuals
 350      (Instance      : Entity_Id;
 351       Is_Formal_Box : Boolean);
 352    --  Similar to previous one. Check the actuals in the instantiation,
 353    --  whose views can change between the point of instantiation and the point
 354    --  of instantiation of the body. In addition, mark the generic renamings
 355    --  as generic actuals, so that they are not compatible with other actuals.
 356    --  Recurse on an actual that is a formal package whose declaration has
 357    --  a box.
 358
 359    function Contains_Instance_Of
 360      (Inner : Entity_Id;
 361       Outer : Entity_Id;
 362       N     : Node_Id)
 363       return  Boolean;
 364    --  Inner is instantiated within the generic Outer. Check whether Inner
 365    --  directly or indirectly contains an instance of Outer or of one of its
 366    --  parents, in the case of a subunit. Each generic unit holds a list of
 367    --  the entities instantiated within (at any depth). This procedure
 368    --  determines whether the set of such lists contains a cycle, i.e. an
 369    --  illegal circular instantiation.
 370
 371    function Denotes_Formal_Package (Pack : Entity_Id) return Boolean;
 372    --  Returns True if E is a formal package of an enclosing generic, or
 373    --  the actual for such a formal in an enclosing instantiation. Used in
 374    --  Restore_Private_Views, to keep the formals of such a package visible
 375    --  on exit from an inner instantiation.
 376
 377    function Find_Actual_Type
 378      (Typ       : Entity_Id;
 379       Gen_Scope : Entity_Id)
 380       return      Entity_Id;
 381    --  When validating the actual types of a child instance, check whether
 382    --  the formal is a formal type of the parent unit, and retrieve the current
 383    --  actual for it. Typ is the entity in the analyzed formal type declaration
 384    --  (component or index type of an array type) and Gen_Scope is the scope of
 385    --  the analyzed formal array type.
 386
 387    function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id;
 388    --  Given the entity of a unit that is an instantiation, retrieve the
 389    --  original instance node. This is used when loading the instantiations
 390    --  of the ancestors of a child generic that is being instantiated.
 391
 392    function In_Same_Declarative_Part
 393      (F_Node : Node_Id;
 394       Inst   : Node_Id)
 395       return   Boolean;
 396    --  True if the instantiation Inst and the given freeze_node F_Node appear
 397    --  within the same declarative part, ignoring subunits, but with no inter-
 398    --  vening suprograms or concurrent units. If true, the freeze node
 399    --  of the instance can be placed after the freeze node of the parent,
 400    --  which it itself an instance.
 401
 402    procedure Set_Instance_Env
 403      (Gen_Unit : Entity_Id;
 404       Act_Unit : Entity_Id);
 405    --  Save current instance on saved environment, to be used to determine
 406    --  the global status of entities in nested instances. Part of Save_Env.
 407    --  called after verifying that the generic unit is legal for the instance.
 408
 409    procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
 410    --  Associate analyzed generic parameter with corresponding
 411    --  instance. Used for semantic checks at instantiation time.
 412
 413    function Has_Been_Exchanged (E : Entity_Id) return Boolean;
 414    --  Traverse the Exchanged_Views list to see if a type was private
 415    --  and has already been flipped during this phase of instantiation.
 416
 417    procedure Hide_Current_Scope;
 418    --  When compiling a generic child unit, the parent context must be
 419    --  present, but the instance and all entities that may be generated
 420    --  must be inserted in the current scope. We leave the current scope
 421    --  on the stack, but make its entities invisible to avoid visibility
 422    --  problems. This is reversed at the end of instantiations. This is
 423    --  not done for the instantiation of the bodies, which only require the
 424    --  instances of the generic parents to be in scope.
 425
 426    procedure Install_Body
 427      (Act_Body : Node_Id;
 428       N        : Node_Id;
 429       Gen_Body : Node_Id;
 430       Gen_Decl : Node_Id);
 431    --  If the instantiation happens textually before the body of the generic,
 432    --  the instantiation of the body must be analyzed after the generic body,
 433    --  and not at the point of instantiation. Such early instantiations can
 434    --  happen if the generic and the instance appear in  a package declaration
 435    --  because the generic body can only appear in the corresponding package
 436    --  body. Early instantiations can also appear if generic, instance and
 437    --  body are all in the declarative part of a subprogram or entry. Entities
 438    --  of packages that are early instantiations are delayed, and their freeze
 439    --  node appears after the generic body.
 440
 441    procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id);
 442    --  Insert freeze node at the end of the declarative part that includes the
 443    --  instance node N. If N is in the visible part of an enclosing package
 444    --  declaration, the freeze node has to be inserted at the end of the
 445    --  private declarations, if any.
 446
 447    procedure Freeze_Subprogram_Body
 448      (Inst_Node : Node_Id;
 449       Gen_Body  : Node_Id;
 450       Pack_Id   : Entity_Id);
 451    --  The generic body may appear textually after the instance, including
 452    --  in the proper body of a stub, or within a different package instance.
 453    --  Given that the instance can only be elaborated after the generic, we
 454    --  place freeze_nodes for the instance and/or for packages that may enclose
 455    --  the instance and the generic, so that the back-end can establish the
 456    --  proper order of elaboration.
 457
 458    procedure Init_Env;
 459    --  Establish environment for subsequent instantiation. Separated from
 460    --  Save_Env because data-structures for visibility handling must be
 461    --  initialized before call to Check_Generic_Child_Unit.
 462
 463    procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
 464    --  When compiling an instance of a child unit the parent (which is
 465    --  itself an instance) is an enclosing scope that must be made
 466    --  immediately visible. This procedure is also used to install the non-
 467    --  generic parent of a generic child unit when compiling its body, so that
 468    --  full views of types in the parent are made visible.
 469
 470    procedure Remove_Parent (In_Body : Boolean := False);
 471    --  Reverse effect after instantiation of child is complete.
 472
 473    procedure Inline_Instance_Body
 474      (N        : Node_Id;
 475       Gen_Unit : Entity_Id;
 476       Act_Decl : Node_Id);
 477    --  If front-end inlining is requested, instantiate the package body,
 478    --  and preserve the visibility of its compilation unit, to insure
 479    --  that successive instantiations succeed.
 480
 481    --  The functions Instantiate_XXX perform various legality checks and build
 482    --  the declarations for instantiated generic parameters.
 483    --  Need to describe what the parameters are ???
 484
 485    function Instantiate_Object
 486      (Formal          : Node_Id;
 487       Actual          : Node_Id;
 488       Analyzed_Formal : Node_Id)
 489       return            List_Id;
 490
 491    function Instantiate_Type
 492      (Formal          : Node_Id;
 493       Actual          : Node_Id;
 494       Analyzed_Formal : Node_Id;
 495       Actual_Decls    : List_Id)
 496       return            Node_Id;
 497
 498    function Instantiate_Formal_Subprogram
 499      (Formal          : Node_Id;
 500       Actual          : Node_Id;
 501       Analyzed_Formal : Node_Id)
 502       return            Node_Id;
 503
 504    function Instantiate_Formal_Package
 505      (Formal          : Node_Id;
 506       Actual          : Node_Id;
 507       Analyzed_Formal : Node_Id)
 508       return            List_Id;
 509    --  If the formal package is declared with a box, special visibility rules
 510    --  apply to its formals: they are in the visible part of the package. This
 511    --  is true in the declarative region of the formal package, that is to say
 512    --  in the enclosing generic or instantiation. For an instantiation, the
 513    --  parameters of the formal package are made visible in an explicit step.
 514    --  Furthermore, if the actual is a visible use_clause, these formals must
 515    --  be made potentially use_visible as well. On exit from the enclosing
 516    --  instantiation, the reverse must be done.
 517
 518    --  For a formal package declared without a box, there are conformance rules
 519    --  that apply to the actuals in the generic declaration and the actuals of
 520    --  the actual package in the enclosing instantiation. The simplest way to
 521    --  apply these rules is to repeat the instantiation of the formal package
 522    --  in the context of the enclosing instance, and compare the generic
 523    --  associations of this instantiation with those of the actual package.
 524
 525    function Is_In_Main_Unit (N : Node_Id) return Boolean;
 526    --  Test if given node is in the main unit
 527
 528    procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id);
 529    --  If the generic appears in a separate non-generic library unit,
 530    --  load the corresponding body to retrieve the body of the generic.
 531    --  N is the node for the generic instantiation, Spec is the generic
 532    --  package declaration.
 533
 534    procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
 535    --  Add the context clause of the unit containing a generic unit to
 536    --  an instantiation that is a compilation unit.
 537
 538    function Get_Associated_Node (N : Node_Id) return Node_Id;
 539    --  In order to propagate semantic information back from the analyzed
 540    --  copy to the original generic, we maintain links between selected nodes
 541    --  in the generic and their corresponding copies. At the end of generic
 542    --  analysis, the routine Save_Global_References traverses the generic
 543    --  tree, examines the semantic information, and preserves the links to
 544    --  those nodes that contain global information. At instantiation, the
 545    --  information from the associated node is placed on the new copy, so
 546    --  that name resolution is not repeated.
 547    --
 548    --  Three kinds of source nodes have associated nodes:
 549    --
 550    --    a) those that can reference (denote) entities, that is identifiers,
 551    --       character literals, expanded_names, operator symbols, operators,
 552    --       and attribute reference nodes. These nodes have an Entity field
 553    --       and are the set of nodes that are in N_Has_Entity.
 554    --
 555    --    b) aggregates (N_Aggregate and N_Extension_Aggregate)
 556    --
 557    --    c) selected components (N_Selected_Component)
 558    --
 559    --  For the first class, the associated node preserves the entity if it is
 560    --  global. If the generic contains nested instantiations, the associated
 561    --  node itself has been recopied, and a chain of them must be followed.
 562    --
 563    --  For aggregates, the associated node allows retrieval of the type, which
 564    --  may otherwise not appear in the generic. The view of this type may be
 565    --  different between generic and instantiation, and the full view can be
 566    --  installed before the instantiation is analyzed. For aggregates of
 567    --  type extensions, the same view exchange may have to be performed for
 568    --  some of the ancestor types, if their view is private at the point of
 569    --  instantiation.
 570    --
 571    --  Nodes that are selected components in the parse tree may be rewritten
 572    --  as expanded names after resolution, and must be treated as potential
 573    --  entity holders. which is why they also have an Associated_Node.
 574    --
 575    --  Nodes that do not come from source, such as freeze nodes, do not appear
 576    --  in the generic tree, and need not have an associated node.
 577    --
 578    --  The associated node is stored in the Associated_Node field. Note that
 579    --  this field overlaps Entity, which is fine, because the whole point is
 580    --  that we don't need or want the normal Entity field in this situation.
 581
 582    procedure Move_Freeze_Nodes
 583      (Out_Of : Entity_Id;
 584       After  : Node_Id;
 585       L      : List_Id);
 586    --  Freeze nodes can be generated in the analysis of a generic unit, but
 587    --  will not be seen by the back-end. It is necessary to move those nodes
 588    --  to the enclosing scope if they freeze an outer entity. We place them
 589    --  at the end of the enclosing generic package, which is semantically
 590    --  neutral.
 591
 592    procedure Pre_Analyze_Actuals (N : Node_Id);
 593    --  Analyze actuals to perform name resolution. Full resolution is done
 594    --  later, when the expected types are known, but names have to be captured
 595    --  before installing parents of generics, that are not visible for the
 596    --  actuals themselves.
 597
 598    procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
 599    --  Verify that an attribute that appears as the default for a formal
 600    --  subprogram is a function or procedure with the correct profile.
 601
 602    -------------------------------------------
 603    -- Data Structures for Generic Renamings --
 604    -------------------------------------------
 605
 606    --  The map Generic_Renamings associates generic entities with their
 607    --  corresponding actuals. Currently used to validate type instances.
 608    --  It will eventually be used for all generic parameters to eliminate
 609    --  the need for overload resolution in the instance.
 610
 611    type Assoc_Ptr is new Int;
 612
 613    Assoc_Null : constant Assoc_Ptr := -1;
 614
 615    type Assoc is record
 616       Gen_Id         : Entity_Id;
 617       Act_Id         : Entity_Id;
 618       Next_In_HTable : Assoc_Ptr;
 619    end record;
 620
 621    package Generic_Renamings is new Table.Table
 622      (Table_Component_Type => Assoc,
 623       Table_Index_Type     => Assoc_Ptr,
 624       Table_Low_Bound      => 0,
 625       Table_Initial        => 10,
 626       Table_Increment      => 100,
 627       Table_Name           => "Generic_Renamings");
 628
 629    --  Variable to hold enclosing instantiation. When the environment is
 630    --  saved for a subprogram inlining, the corresponding Act_Id is empty.
 631
 632    Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null);
 633
 634    --  Hash table for associations
 635
 636    HTable_Size : constant := 37;
 637    type HTable_Range is range 0 .. HTable_Size - 1;
 638
 639    procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
 640    function  Next_Assoc     (E : Assoc_Ptr) return Assoc_Ptr;
 641    function Get_Gen_Id      (E : Assoc_Ptr) return Entity_Id;
 642    function Hash            (F : Entity_Id)   return HTable_Range;
 643
 644    package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
 645       Header_Num => HTable_Range,
 646       Element    => Assoc,
 647       Elmt_Ptr   => Assoc_Ptr,
 648       Null_Ptr   => Assoc_Null,
 649       Set_Next   => Set_Next_Assoc,
 650       Next       => Next_Assoc,
 651       Key        => Entity_Id,
 652       Get_Key    => Get_Gen_Id,
 653       Hash       => Hash,
 654       Equal      => "=");
 655
 656    Exchanged_Views : Elist_Id;
 657    --  This list holds the private views that have been exchanged during
 658    --  instantiation to restore the visibility of the generic declaration.
 659    --  (see comments above). After instantiation, the current visibility is
 660    --  reestablished by means of a traversal of this list.
 661
 662    Hidden_Entities : Elist_Id;
 663    --  This list holds the entities of the current scope that are removed
 664    --  from immediate visibility when instantiating a child unit. Their
 665    --  visibility is restored in Remove_Parent.
 666
 667    --  Because instantiations can be recursive, the following must be saved
 668    --  on entry and restored on exit from an instantiation (spec or body).
 669    --  This is done by the two procedures Save_Env and Restore_Env. For
 670    --  package and subprogram instantiations (but not for the body instances)
 671    --  the action of Save_Env is done in two steps: Init_Env is called before
 672    --  Check_Generic_Child_Unit, because setting the parent instances requires
 673    --  that the visibility data structures be properly initialized. Once the
 674    --  generic is unit is validated, Set_Instance_Env completes Save_Env.
 675
 676    type Instance_Env is record
 677       Ada_Version         : Ada_Version_Type;
 678       Instantiated_Parent : Assoc;
 679       Exchanged_Views     : Elist_Id;
 680       Hidden_Entities     : Elist_Id;
 681       Current_Sem_Unit    : Unit_Number_Type;
 682    end record;
 683
 684    package Instance_Envs is new Table.Table (
 685      Table_Component_Type => Instance_Env,
 686      Table_Index_Type     => Int,
 687      Table_Low_Bound      => 0,
 688      Table_Initial        => 32,
 689      Table_Increment      => 100,
 690      Table_Name           => "Instance_Envs");
 691
 692    procedure Restore_Private_Views
 693      (Pack_Id    : Entity_Id;
 694       Is_Package : Boolean := True);
 695    --  Restore the private views of external types, and unmark the generic
 696    --  renamings of actuals, so that they become comptible subtypes again.
 697    --  For subprograms, Pack_Id is the package constructed to hold the
 698    --  renamings.
 699
 700    procedure Switch_View (T : Entity_Id);
 701    --  Switch the partial and full views of a type and its private
 702    --  dependents (i.e. its subtypes and derived types).
 703
 704    ------------------------------------
 705    -- Structures for Error Reporting --
 706    ------------------------------------
 707
 708    Instantiation_Node : Node_Id;
 709    --  Used by subprograms that validate instantiation of formal parameters
 710    --  where there might be no actual on which to place the error message.
 711    --  Also used to locate the instantiation node for generic subunits.
 712
 713    Instantiation_Error : exception;
 714    --  When there is a semantic error in the generic parameter matching,
 715    --  there is no point in continuing the instantiation, because the
 716    --  number of cascaded errors is unpredictable. This exception aborts
 717    --  the instantiation process altogether.
 718
 719    S_Adjustment : Sloc_Adjustment;
 720    --  Offset created for each node in an instantiation, in order to keep
 721    --  track of the source position of the instantiation in each of its nodes.
 722    --  A subsequent semantic error or warning on a construct of the instance
 723    --  points to both places: the original generic node, and the point of
 724    --  instantiation. See Sinput and Sinput.L for additional details.
 725
 726    ------------------------------------------------------------
 727    -- Data structure for keeping track when inside a Generic --
 728    ------------------------------------------------------------
 729
 730    --  The following table is used to save values of the Inside_A_Generic
 731    --  flag (see spec of Sem) when they are saved by Start_Generic.
 732
 733    package Generic_Flags is new Table.Table (
 734      Table_Component_Type => Boolean,
 735      Table_Index_Type     => Int,
 736      Table_Low_Bound      => 0,
 737      Table_Initial        => 32,
 738      Table_Increment      => 200,
 739      Table_Name           => "Generic_Flags");
 740
 741    ---------------------------
 742    -- Abandon_Instantiation --
 743    ---------------------------
 744
 745    procedure Abandon_Instantiation (N : Node_Id) is
 746    begin
 747       Error_Msg_N ("instantiation abandoned!", N);
 748       raise Instantiation_Error;
 749    end Abandon_Instantiation;
 750
 751    --------------------------
 752    -- Analyze_Associations --
 753    --------------------------
 754
 755    function Analyze_Associations
 756      (I_Node  : Node_Id;
 757       Formals : List_Id;
 758       F_Copy  : List_Id)
 759       return    List_Id
 760    is
 761       Actual_Types    : constant Elist_Id  := New_Elmt_List;
 762       Assoc           : constant List_Id   := New_List;
 763       Defaults        : constant Elist_Id  := New_Elmt_List;
 764       Gen_Unit        : constant Entity_Id := Defining_Entity
 765                                                 (Parent (F_Copy));
 766       Actuals         : List_Id;
 767       Actual          : Node_Id;
 768       Formal          : Node_Id;
 769       Next_Formal     : Node_Id;
 770       Temp_Formal     : Node_Id;
 771       Analyzed_Formal : Node_Id;
 772       Match           : Node_Id;
 773       Named           : Node_Id;
 774       First_Named     : Node_Id := Empty;
 775       Found_Assoc     : Node_Id;
 776       Is_Named_Assoc  : Boolean;
 777       Num_Matched     : Int := 0;
 778       Num_Actuals     : Int := 0;
 779
 780       function Matching_Actual
 781         (F    : Entity_Id;
 782          A_F  : Entity_Id)
 783          return Node_Id;
 784       --  Find actual that corresponds to a given a formal parameter. If the
 785       --  actuals are positional, return the next one, if any. If the actuals
 786       --  are named, scan the parameter associations to find the right one.
 787       --  A_F is the corresponding entity in the analyzed generic,which is
 788       --  placed on the selector name for ASIS use.
 789
 790       procedure Set_Analyzed_Formal;
 791       --  Find the node in the generic copy that corresponds to a given formal.
 792       --  The semantic information on this node is used to perform legality
 793       --  checks on the actuals. Because semantic analysis can introduce some
 794       --  anonymous entities or modify the declaration node itself, the
 795       --  correspondence between the two lists is not one-one. In addition to
 796       --  anonymous types, the presence a formal equality will introduce an
 797       --  implicit declaration for the corresponding inequality.
 798
 799       ---------------------
 800       -- Matching_Actual --
 801       ---------------------
 802
 803       function Matching_Actual
 804         (F    : Entity_Id;
 805          A_F  : Entity_Id)
 806          return Node_Id
 807       is
 808          Found : Node_Id;
 809          Prev  : Node_Id;
 810
 811       begin
 812          Is_Named_Assoc := False;
 813
 814          --  End of list of purely positional parameters
 815
 816          if No (Actual) then
 817             Found := Empty;
 818
 819          --  Case of positional parameter corresponding to current formal
 820
 821          elsif No (Selector_Name (Actual)) then
 822             Found := Explicit_Generic_Actual_Parameter (Actual);
 823             Found_Assoc := Actual;
 824             Num_Matched := Num_Matched + 1;
 825             Next (Actual);
 826
 827          --  Otherwise scan list of named actuals to find the one with the
 828          --  desired name. All remaining actuals have explicit names.
 829
 830          else
 831             Is_Named_Assoc := True;
 832             Found := Empty;
 833             Prev  := Empty;
 834
 835             while Present (Actual) loop
 836                if Chars (Selector_Name (Actual)) = Chars (F) then
 837                   Found := Explicit_Generic_Actual_Parameter (Actual);
 838                   Set_Entity (Selector_Name (Actual), A_F);
 839                   Set_Etype  (Selector_Name (Actual), Etype (A_F));
 840                   Generate_Reference (A_F, Selector_Name (Actual));
 841                   Found_Assoc := Actual;
 842                   Num_Matched := Num_Matched + 1;
 843                   exit;
 844                end if;
 845
 846                Prev := Actual;
 847                Next (Actual);
 848             end loop;
 849
 850             --  Reset for subsequent searches. In most cases the named
 851             --  associations are in order. If they are not, we reorder them
 852             --  to avoid scanning twice the same actual. This is not just a
 853             --  question of efficiency: there may be multiple defaults with
 854             --  boxes that have the same name. In a nested instantiation we
 855             --  insert actuals for those defaults, and cannot rely on their
 856             --  names to disambiguate them.
 857
 858             if Actual = First_Named  then
 859                Next (First_Named);
 860
 861             elsif Present (Actual) then
 862                Insert_Before (First_Named, Remove_Next (Prev));
 863             end if;
 864
 865             Actual := First_Named;
 866          end if;
 867
 868          return Found;
 869       end Matching_Actual;
 870
 871       -------------------------
 872       -- Set_Analyzed_Formal --
 873       -------------------------
 874
 875       procedure Set_Analyzed_Formal is
 876          Kind : Node_Kind;
 877       begin
 878          while Present (Analyzed_Formal) loop
 879             Kind := Nkind (Analyzed_Formal);
 880
 881             case Nkind (Formal) is
 882
 883                when N_Formal_Subprogram_Declaration =>
 884                   exit when Kind = N_Formal_Subprogram_Declaration
 885                     and then
 886                       Chars
 887                         (Defining_Unit_Name (Specification (Formal))) =
 888                       Chars
 889                         (Defining_Unit_Name (Specification (Analyzed_Formal)));
 890
 891                when N_Formal_Package_Declaration =>
 892                   exit when
 893                     Kind = N_Formal_Package_Declaration
 894                       or else
 895                     Kind = N_Generic_Package_Declaration;
 896
 897                when N_Use_Package_Clause | N_Use_Type_Clause => exit;
 898
 899                when others =>
 900
 901                   --  Skip freeze nodes, and nodes inserted to replace
 902                   --  unrecognized pragmas.
 903
 904                   exit when
 905                     Kind /= N_Formal_Subprogram_Declaration
 906                       and then Kind /= N_Subprogram_Declaration
 907                       and then Kind /= N_Freeze_Entity
 908                       and then Kind /= N_Null_Statement
 909                       and then Kind /= N_Itype_Reference
 910                       and then Chars (Defining_Identifier (Formal)) =
 911                                Chars (Defining_Identifier (Analyzed_Formal));
 912             end case;
 913
 914             Next (Analyzed_Formal);
 915          end loop;
 916
 917       end Set_Analyzed_Formal;
 918
 919    --  Start of processing for Analyze_Associations
 920
 921    begin
 922       --  If named associations are present, save the first named association
 923       --  (it may of course be Empty) to facilitate subsequent name search.
 924
 925       Actuals := Generic_Associations (I_Node);
 926
 927       if Present (Actuals) then
 928          First_Named := First (Actuals);
 929
 930          while Present (First_Named)
 931            and then No (Selector_Name (First_Named))
 932          loop
 933             Num_Actuals := Num_Actuals + 1;
 934             Next (First_Named);
 935          end loop;
 936       end if;
 937
 938       Named := First_Named;
 939       while Present (Named) loop
 940          if No (Selector_Name (Named)) then
 941             Error_Msg_N ("invalid positional actual after named one", Named);
 942             Abandon_Instantiation (Named);
 943          end if;
 944
 945          --  A named association may lack an actual parameter, if it was
 946          --  introduced for a default subprogram that turns out to be local
 947          --  to the outer instantiation.
 948
 949          if Present (Explicit_Generic_Actual_Parameter (Named)) then
 950             Num_Actuals := Num_Actuals + 1;
 951          end if;
 952
 953          Next (Named);
 954       end loop;
 955
 956       if Present (Formals) then
 957          Formal := First_Non_Pragma (Formals);
 958          Analyzed_Formal := First_Non_Pragma (F_Copy);
 959
 960          if Present (Actuals) then
 961             Actual := First (Actuals);
 962
 963          --  All formals should have default values
 964
 965          else
 966             Actual := Empty;
 967          end if;
 968
 969          while Present (Formal) loop
 970             Set_Analyzed_Formal;
 971             Next_Formal := Next_Non_Pragma (Formal);
 972
 973             case Nkind (Formal) is
 974                when N_Formal_Object_Declaration =>
 975                   Match :=
 976                     Matching_Actual (
 977                       Defining_Identifier (Formal),
 978                       Defining_Identifier (Analyzed_Formal));
 979
 980                   Append_List
 981                     (Instantiate_Object (Formal, Match, Analyzed_Formal),
 982                      Assoc);
 983
 984                when N_Formal_Type_Declaration =>
 985                   Match :=
 986                     Matching_Actual (
 987                       Defining_Identifier (Formal),
 988                       Defining_Identifier (Analyzed_Formal));
 989
 990                   if No (Match) then
 991                      Error_Msg_Sloc := Sloc (Gen_Unit);
 992                      Error_Msg_NE
 993                        ("missing actual&",
 994                          Instantiation_Node, Defining_Identifier (Formal));
 995                      Error_Msg_NE ("\in instantiation of & declared#",
 996                          Instantiation_Node, Gen_Unit);
 997                      Abandon_Instantiation (Instantiation_Node);
 998
 999                   else
1000                      Analyze (Match);
1001                      Append_To (Assoc,
1002                        Instantiate_Type
1003                          (Formal, Match, Analyzed_Formal, Assoc));
1004
1005                      --  an instantiation is a freeze point for the actuals,
1006                      --  unless this is a rewritten formal package.
1007
1008                      if Nkind (I_Node) /= N_Formal_Package_Declaration then
1009                         Append_Elmt (Entity (Match), Actual_Types);
1010                      end if;
1011                   end if;
1012
1013                   --  A remote access-to-class-wide type must not be an
1014                   --  actual parameter for a generic formal of an access
1015                   --  type (E.2.2 (17)).
1016
1017                   if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
1018                     and then
1019                       Nkind (Formal_Type_Definition (Analyzed_Formal)) =
1020                                             N_Access_To_Object_Definition
1021                   then
1022                      Validate_Remote_Access_To_Class_Wide_Type (Match);
1023                   end if;
1024
1025                when N_Formal_Subprogram_Declaration =>
1026                   Match :=
1027                     Matching_Actual (
1028                       Defining_Unit_Name (Specification (Formal)),
1029                       Defining_Unit_Name (Specification (Analyzed_Formal)));
1030
1031                   --  If the formal subprogram has the same name as
1032                   --  another formal subprogram of the generic, then
1033                   --  a named association is illegal (12.3(9)). Exclude
1034                   --  named associations that are generated for a nested
1035                   --  instance.
1036
1037                   if Present (Match)
1038                     and then Is_Named_Assoc
1039                     and then Comes_From_Source (Found_Assoc)
1040                   then
1041                      Temp_Formal := First (Formals);
1042                      while Present (Temp_Formal) loop
1043                         if Nkind (Temp_Formal) =
1044                              N_Formal_Subprogram_Declaration
1045                           and then Temp_Formal /= Formal
1046                           and then
1047                             Chars (Selector_Name (Found_Assoc)) =
1048                               Chars (Defining_Unit_Name
1049                                        (Specification (Temp_Formal)))
1050                         then
1051                            Error_Msg_N
1052                              ("name not allowed for overloaded formal",
1053                               Found_Assoc);
1054                            Abandon_Instantiation (Instantiation_Node);
1055                         end if;
1056
1057                         Next (Temp_Formal);
1058                      end loop;
1059                   end if;
1060
1061                   Append_To (Assoc,
1062                     Instantiate_Formal_Subprogram
1063                       (Formal, Match, Analyzed_Formal));
1064
1065                   if No (Match)
1066                     and then Box_Present (Formal)
1067                   then
1068                      Append_Elmt
1069                        (Defining_Unit_Name (Specification (Last (Assoc))),
1070                          Defaults);
1071                   end if;
1072
1073                when N_Formal_Package_Declaration =>
1074                   Match :=
1075                     Matching_Actual (
1076                       Defining_Identifier (Formal),
1077                       Defining_Identifier (Original_Node (Analyzed_Formal)));
1078
1079                   if No (Match) then
1080                      Error_Msg_Sloc := Sloc (Gen_Unit);
1081                      Error_Msg_NE
1082                        ("missing actual&",
1083                          Instantiation_Node, Defining_Identifier (Formal));
1084                      Error_Msg_NE ("\in instantiation of & declared#",
1085                          Instantiation_Node, Gen_Unit);
1086
1087                      Abandon_Instantiation (Instantiation_Node);
1088
1089                   else
1090                      Analyze (Match);
1091                      Append_List
1092                        (Instantiate_Formal_Package
1093                          (Formal, Match, Analyzed_Formal),
1094                         Assoc);
1095                   end if;
1096
1097                --  For use type and use package appearing in the context
1098                --  clause, we have already copied them, so we can just
1099                --  move them where they belong (we mustn't recopy them
1100                --  since this would mess up the Sloc values).
1101
1102                when N_Use_Package_Clause |
1103                     N_Use_Type_Clause    =>
1104                   Remove (Formal);
1105                   Append (Formal, Assoc);
1106
1107                when others =>
1108                   raise Program_Error;
1109
1110             end case;
1111
1112             Formal := Next_Formal;
1113             Next_Non_Pragma (Analyzed_Formal);
1114          end loop;
1115
1116          if Num_Actuals > Num_Matched then
1117             Error_Msg_Sloc := Sloc (Gen_Unit);
1118
1119             if Present (Selector_Name (Actual)) then
1120                Error_Msg_NE
1121                  ("unmatched actual&",
1122                     Actual, Selector_Name (Actual));
1123                Error_Msg_NE ("\in instantiation of& declared#",
1124                     Actual, Gen_Unit);
1125             else
1126                Error_Msg_NE
1127                  ("unmatched actual in instantiation of& declared#",
1128                    Actual, Gen_Unit);
1129             end if;
1130          end if;
1131
1132       elsif Present (Actuals) then
1133          Error_Msg_N
1134            ("too many actuals in generic instantiation", Instantiation_Node);
1135       end if;
1136
1137       declare
1138          Elmt : Elmt_Id := First_Elmt (Actual_Types);
1139
1140       begin
1141          while Present (Elmt) loop
1142             Freeze_Before (I_Node, Node (Elmt));
1143             Next_Elmt (Elmt);
1144          end loop;
1145       end;
1146
1147       --  If there are default subprograms, normalize the tree by adding
1148       --  explicit associations for them. This is required if the instance
1149       --  appears within a generic.
1150
1151       declare
1152          Elmt  : Elmt_Id;
1153          Subp  : Entity_Id;
1154          New_D : Node_Id;
1155
1156       begin
1157          Elmt := First_Elmt (Defaults);
1158          while Present (Elmt) loop
1159             if No (Actuals) then
1160                Actuals := New_List;
1161                Set_Generic_Associations (I_Node, Actuals);
1162             end if;
1163
1164             Subp := Node (Elmt);
1165             New_D :=
1166               Make_Generic_Association (Sloc (Subp),
1167                 Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
1168                   Explicit_Generic_Actual_Parameter =>
1169                     New_Occurrence_Of (Subp, Sloc (Subp)));
1170             Mark_Rewrite_Insertion (New_D);
1171             Append_To (Actuals, New_D);
1172             Next_Elmt (Elmt);
1173          end loop;
1174       end;
1175
1176       return Assoc;
1177    end Analyze_Associations;
1178
1179    -------------------------------
1180    -- Analyze_Formal_Array_Type --
1181    -------------------------------
1182
1183    procedure Analyze_Formal_Array_Type
1184      (T   : in out Entity_Id;
1185       Def : Node_Id)
1186    is
1187       DSS : Node_Id;
1188
1189    begin
1190       --  Treated like a non-generic array declaration, with
1191       --  additional semantic checks.
1192
1193       Enter_Name (T);
1194
1195       if Nkind (Def) = N_Constrained_Array_Definition then
1196          DSS := First (Discrete_Subtype_Definitions (Def));
1197          while Present (DSS) loop
1198             if Nkind (DSS) = N_Subtype_Indication
1199               or else Nkind (DSS) = N_Range
1200               or else Nkind (DSS) = N_Attribute_Reference
1201             then
1202                Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
1203             end if;
1204
1205             Next (DSS);
1206          end loop;
1207       end if;
1208
1209       Array_Type_Declaration (T, Def);
1210       Set_Is_Generic_Type (Base_Type (T));
1211
1212       if Ekind (Component_Type (T)) = E_Incomplete_Type
1213         and then No (Full_View (Component_Type (T)))
1214       then
1215          Error_Msg_N ("premature usage of incomplete type", Def);
1216
1217       elsif Is_Internal (Component_Type (T))
1218         and then Nkind (Original_Node
1219                         (Subtype_Indication (Component_Definition (Def))))
1220           /= N_Attribute_Reference
1221       then
1222          Error_Msg_N
1223            ("only a subtype mark is allowed in a formal",
1224               Subtype_Indication (Component_Definition (Def)));
1225       end if;
1226
1227    end Analyze_Formal_Array_Type;
1228
1229    ---------------------------------------------
1230    -- Analyze_Formal_Decimal_Fixed_Point_Type --
1231    ---------------------------------------------
1232
1233    --  As for other generic types, we create a valid type representation
1234    --  with legal but arbitrary attributes, whose values are never considered
1235    --  static. For all scalar types we introduce an anonymous base type, with
1236    --  the same attributes. We choose the corresponding integer type to be
1237    --  Standard_Integer.
1238
1239    procedure Analyze_Formal_Decimal_Fixed_Point_Type
1240      (T   : Entity_Id;
1241       Def : Node_Id)
1242    is
1243       Loc       : constant Source_Ptr := Sloc (Def);
1244       Base      : constant Entity_Id :=
1245                     New_Internal_Entity
1246                       (E_Decimal_Fixed_Point_Type,
1247                        Current_Scope, Sloc (Def), 'G');
1248       Int_Base  : constant Entity_Id := Standard_Integer;
1249       Delta_Val : constant Ureal := Ureal_1;
1250       Digs_Val  : constant Uint  := Uint_6;
1251
1252    begin
1253       Enter_Name (T);
1254
1255       Set_Etype          (Base, Base);
1256       Set_Size_Info      (Base, Int_Base);
1257       Set_RM_Size        (Base, RM_Size (Int_Base));
1258       Set_First_Rep_Item (Base, First_Rep_Item (Int_Base));
1259       Set_Digits_Value   (Base, Digs_Val);
1260       Set_Delta_Value    (Base, Delta_Val);
1261       Set_Small_Value    (Base, Delta_Val);
1262       Set_Scalar_Range   (Base,
1263         Make_Range (Loc,
1264           Low_Bound  => Make_Real_Literal (Loc, Ureal_1),
1265           High_Bound => Make_Real_Literal (Loc, Ureal_1)));
1266
1267       Set_Is_Generic_Type (Base);
1268       Set_Parent          (Base, Parent (Def));
1269
1270       Set_Ekind          (T, E_Decimal_Fixed_Point_Subtype);
1271       Set_Etype          (T, Base);
1272       Set_Size_Info      (T, Int_Base);
1273       Set_RM_Size        (T, RM_Size (Int_Base));
1274       Set_First_Rep_Item (T, First_Rep_Item (Int_Base));
1275       Set_Digits_Value   (T, Digs_Val);
1276       Set_Delta_Value    (T, Delta_Val);
1277       Set_Small_Value    (T, Delta_Val);
1278       Set_Scalar_Range   (T, Scalar_Range (Base));
1279
1280       Check_Restriction (No_Fixed_Point, Def);
1281    end Analyze_Formal_Decimal_Fixed_Point_Type;
1282
1283    ---------------------------------
1284    -- Analyze_Formal_Derived_Type --
1285    ---------------------------------
1286
1287    procedure Analyze_Formal_Derived_Type
1288      (N   : Node_Id;
1289       T   : Entity_Id;
1290       Def : Node_Id)
1291    is
1292       Loc      : constant Source_Ptr := Sloc (Def);
1293       Unk_Disc : constant Boolean    := Unknown_Discriminants_Present (N);
1294       New_N    : Node_Id;
1295
1296    begin
1297       Set_Is_Generic_Type (T);
1298
1299       if Private_Present (Def) then
1300          New_N :=
1301            Make_Private_Extension_Declaration (Loc,
1302              Defining_Identifier           => T,
1303              Discriminant_Specifications   => Discriminant_Specifications (N),
1304              Unknown_Discriminants_Present => Unk_Disc,
1305              Subtype_Indication            => Subtype_Mark (Def));
1306
1307          Set_Abstract_Present (New_N, Abstract_Present (Def));
1308
1309       else
1310          New_N :=
1311            Make_Full_Type_Declaration (Loc,
1312              Defining_Identifier => T,
1313              Discriminant_Specifications =>
1314                Discriminant_Specifications (Parent (T)),
1315               Type_Definition =>
1316                 Make_Derived_Type_Definition (Loc,
1317                   Subtype_Indication => Subtype_Mark (Def)));
1318
1319          Set_Abstract_Present
1320            (Type_Definition (New_N), Abstract_Present (Def));
1321       end if;
1322
1323       Rewrite (N, New_N);
1324       Analyze (N);
1325
1326       if Unk_Disc then
1327          if not Is_Composite_Type (T) then
1328             Error_Msg_N
1329               ("unknown discriminants not allowed for elementary types", N);
1330          else
1331             Set_Has_Unknown_Discriminants (T);
1332             Set_Is_Constrained (T, False);
1333          end if;
1334       end if;
1335
1336       --  If the parent type has a known size, so does the formal, which
1337       --  makes legal representation clauses that involve the formal.
1338
1339       Set_Size_Known_At_Compile_Time
1340         (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
1341
1342    end Analyze_Formal_Derived_Type;
1343
1344    ----------------------------------
1345    -- Analyze_Formal_Discrete_Type --
1346    ----------------------------------
1347
1348    --  The operations defined for a discrete types are those of an
1349    --  enumeration type. The size is set to an arbitrary value, for use
1350    --  in analyzing the generic unit.
1351
1352    procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is
1353       Loc : constant Source_Ptr := Sloc (Def);
1354       Lo  : Node_Id;
1355       Hi  : Node_Id;
1356
1357    begin
1358       Enter_Name     (T);
1359       Set_Ekind      (T, E_Enumeration_Type);
1360       Set_Etype      (T, T);
1361       Init_Size      (T, 8);
1362       Init_Alignment (T);
1363
1364       --  For semantic analysis, the bounds of the type must be set to some
1365       --  non-static value. The simplest is to create attribute nodes for
1366       --  those bounds, that refer to the type itself. These bounds are never
1367       --  analyzed but serve as place-holders.
1368
1369       Lo :=
1370         Make_Attribute_Reference (Loc,
1371           Attribute_Name => Name_First,
1372           Prefix => New_Reference_To (T, Loc));
1373       Set_Etype (Lo, T);
1374
1375       Hi :=
1376         Make_Attribute_Reference (Loc,
1377           Attribute_Name => Name_Last,
1378           Prefix => New_Reference_To (T, Loc));
1379       Set_Etype (Hi, T);
1380
1381       Set_Scalar_Range (T,
1382         Make_Range (Loc,
1383           Low_Bound => Lo,
1384           High_Bound => Hi));
1385
1386    end Analyze_Formal_Discrete_Type;
1387
1388    ----------------------------------
1389    -- Analyze_Formal_Floating_Type --
1390    ---------------------------------
1391
1392    procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is
1393       Base : constant Entity_Id :=
1394                New_Internal_Entity
1395                  (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
1396
1397    begin
1398       --  The various semantic attributes are taken from the predefined type
1399       --  Float, just so that all of them are initialized. Their values are
1400       --  never used because no constant folding or expansion takes place in
1401       --  the generic itself.
1402
1403       Enter_Name (T);
1404       Set_Ekind        (T, E_Floating_Point_Subtype);
1405       Set_Etype        (T, Base);
1406       Set_Size_Info    (T,              (Standard_Float));
1407       Set_RM_Size      (T, RM_Size      (Standard_Float));
1408       Set_Digits_Value (T, Digits_Value (Standard_Float));
1409       Set_Scalar_Range (T, Scalar_Range (Standard_Float));
1410
1411       Set_Is_Generic_Type (Base);
1412       Set_Etype           (Base, Base);
1413       Set_Size_Info       (Base,              (Standard_Float));
1414       Set_RM_Size         (Base, RM_Size      (Standard_Float));
1415       Set_Digits_Value    (Base, Digits_Value (Standard_Float));
1416       Set_Scalar_Range    (Base, Scalar_Range (Standard_Float));
1417       Set_Parent          (Base, Parent (Def));
1418
1419       Check_Restriction (No_Floating_Point, Def);
1420    end Analyze_Formal_Floating_Type;
1421
1422    ---------------------------------
1423    -- Analyze_Formal_Modular_Type --
1424    ---------------------------------
1425
1426    procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is
1427    begin
1428       --  Apart from their entity kind, generic modular types are treated
1429       --  like signed integer types, and have the same attributes.
1430
1431       Analyze_Formal_Signed_Integer_Type (T, Def);
1432       Set_Ekind (T, E_Modular_Integer_Subtype);
1433       Set_Ekind (Etype (T), E_Modular_Integer_Type);
1434
1435    end Analyze_Formal_Modular_Type;
1436
1437    ---------------------------------------
1438    -- Analyze_Formal_Object_Declaration --
1439    ---------------------------------------
1440
1441    procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
1442       E  : constant Node_Id := Expression (N);
1443       Id : constant Node_Id := Defining_Identifier (N);
1444       K  : Entity_Kind;
1445       T  : Node_Id;
1446
1447    begin
1448       Enter_Name (Id);
1449
1450       --  Determine the mode of the formal object
1451
1452       if Out_Present (N) then
1453          K := E_Generic_In_Out_Parameter;
1454
1455          if not In_Present (N) then
1456             Error_Msg_N ("formal generic objects cannot have mode OUT", N);
1457          end if;
1458
1459       else
1460          K := E_Generic_In_Parameter;
1461       end if;
1462
1463       Find_Type (Subtype_Mark (N));
1464       T  := Entity (Subtype_Mark (N));
1465
1466       if Ekind (T) = E_Incomplete_Type then
1467          Error_Msg_N ("premature usage of incomplete type", Subtype_Mark (N));
1468       end if;
1469
1470       if K = E_Generic_In_Parameter then
1471
1472          --  Ada 2005 (AI-287): Limited aggregates allowed in generic formals
1473
1474          if Ada_Version < Ada_05 and then Is_Limited_Type (T) then
1475             Error_Msg_N
1476               ("generic formal of mode IN must not be of limited type", N);
1477             Explain_Limited_Type (T, N);
1478          end if;
1479
1480          if Is_Abstract (T) then
1481             Error_Msg_N
1482               ("generic formal of mode IN must not be of abstract type", N);
1483          end if;
1484
1485          if Present (E) then
1486             Analyze_Per_Use_Expression (E, T);
1487          end if;
1488
1489          Set_Ekind (Id, K);
1490          Set_Etype (Id, T);
1491
1492       --  Case of generic IN OUT parameter.
1493
1494       else
1495          --  If the formal has an unconstrained type, construct its
1496          --  actual subtype, as is done for subprogram formals. In this
1497          --  fashion, all its uses can refer to specific bounds.
1498
1499          Set_Ekind (Id, K);
1500          Set_Etype (Id, T);
1501
1502          if (Is_Array_Type (T)
1503               and then not Is_Constrained (T))
1504            or else
1505             (Ekind (T) = E_Record_Type
1506               and then Has_Discriminants (T))
1507          then
1508             declare
1509                Non_Freezing_Ref : constant Node_Id :=
1510                                     New_Reference_To (Id, Sloc (Id));
1511                Decl : Node_Id;
1512
1513             begin
1514                --  Make sure that the actual subtype doesn't generate
1515                --  bogus freezing.
1516
1517                Set_Must_Not_Freeze (Non_Freezing_Ref);
1518                Decl := Build_Actual_Subtype (T, Non_Freezing_Ref);
1519                Insert_Before_And_Analyze (N, Decl);
1520                Set_Actual_Subtype (Id, Defining_Identifier (Decl));
1521             end;
1522          else
1523             Set_Actual_Subtype (Id, T);
1524          end if;
1525
1526          if Present (E) then
1527             Error_Msg_N
1528               ("initialization not allowed for `IN OUT` formals", N);
1529          end if;
1530       end if;
1531
1532    end Analyze_Formal_Object_Declaration;
1533
1534    ----------------------------------------------
1535    -- Analyze_Formal_Ordinary_Fixed_Point_Type --
1536    ----------------------------------------------
1537
1538    procedure Analyze_Formal_Ordinary_Fixed_Point_Type
1539      (T   : Entity_Id;
1540       Def : Node_Id)
1541    is
1542       Loc  : constant Source_Ptr := Sloc (Def);
1543       Base : constant Entity_Id :=
1544                New_Internal_Entity
1545                  (E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G');
1546    begin
1547       --  The semantic attributes are set for completeness only, their
1548       --  values will never be used, because all properties of the type
1549       --  are non-static.
1550
1551       Enter_Name (T);
1552       Set_Ekind            (T, E_Ordinary_Fixed_Point_Subtype);
1553       Set_Etype            (T, Base);
1554       Set_Size_Info        (T, Standard_Integer);
1555       Set_RM_Size          (T, RM_Size (Standard_Integer));
1556       Set_Small_Value      (T, Ureal_1);
1557       Set_Delta_Value      (T, Ureal_1);
1558       Set_Scalar_Range     (T,
1559         Make_Range (Loc,
1560           Low_Bound  => Make_Real_Literal (Loc, Ureal_1),
1561           High_Bound => Make_Real_Literal (Loc, Ureal_1)));
1562
1563       Set_Is_Generic_Type (Base);
1564       Set_Etype           (Base, Base);
1565       Set_Size_Info       (Base, Standard_Integer);
1566       Set_RM_Size         (Base, RM_Size (Standard_Integer));
1567       Set_Small_Value     (Base, Ureal_1);
1568       Set_Delta_Value     (Base, Ureal_1);
1569       Set_Scalar_Range    (Base, Scalar_Range (T));
1570       Set_Parent          (Base, Parent (Def));
1571
1572       Check_Restriction (No_Fixed_Point, Def);
1573    end Analyze_Formal_Ordinary_Fixed_Point_Type;
1574
1575    ----------------------------
1576    -- Analyze_Formal_Package --
1577    ----------------------------
1578
1579    procedure Analyze_Formal_Package (N : Node_Id) is
1580       Loc              : constant Source_Ptr := Sloc (N);
1581       Pack_Id          : constant Entity_Id := Defining_Identifier (N);
1582       Formal           : Entity_Id;
1583       Gen_Id           : constant Node_Id    := Name (N);
1584       Gen_Decl         : Node_Id;
1585       Gen_Unit         : Entity_Id;
1586       New_N            : Node_Id;
1587       Parent_Installed : Boolean := False;
1588       Renaming         : Node_Id;
1589       Parent_Instance  : Entity_Id;
1590       Renaming_In_Par  : Entity_Id;
1591
1592    begin
1593       Text_IO_Kludge (Gen_Id);
1594
1595       Init_Env;
1596       Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
1597       Gen_Unit := Entity (Gen_Id);
1598
1599       if Ekind (Gen_Unit) /= E_Generic_Package then
1600          Error_Msg_N ("expect generic package name", Gen_Id);
1601          Restore_Env;
1602          return;
1603
1604       elsif  Gen_Unit = Current_Scope then
1605          Error_Msg_N
1606            ("generic package cannot be used as a formal package of itself",
1607              Gen_Id);
1608          Restore_Env;
1609          return;
1610
1611       elsif In_Open_Scopes (Gen_Unit) then
1612          if Is_Compilation_Unit (Gen_Unit)
1613            and then Is_Child_Unit (Current_Scope)
1614          then
1615             --  Special-case the error when the formal is a parent, and
1616             --  continue analysis to minimize cascaded errors.
1617
1618             Error_Msg_N
1619               ("generic parent cannot be used as formal package "
1620                 & "of a child unit",
1621                 Gen_Id);
1622
1623          else
1624             Error_Msg_N
1625               ("generic package cannot be used as a formal package "
1626                 & "within itself",
1627                 Gen_Id);
1628             Restore_Env;
1629             return;
1630          end if;
1631       end if;
1632
1633       --  Check for a formal package that is a package renaming.
1634
1635       if Present (Renamed_Object (Gen_Unit)) then
1636          Gen_Unit := Renamed_Object (Gen_Unit);
1637       end if;
1638
1639       --  The formal package is treated like a regular instance, but only
1640       --  the specification needs to be instantiated, to make entities visible.
1641
1642       if not Box_Present (N) then
1643          Hidden_Entities := New_Elmt_List;
1644          Analyze_Package_Instantiation (N);
1645
1646          if Parent_Installed then
1647             Remove_Parent;
1648          end if;
1649
1650       else
1651          --  If there are no generic associations, the generic parameters
1652          --  appear as local entities and are instantiated like them. We copy
1653          --  the generic package declaration as if it were an instantiation,
1654          --  and analyze it like a regular package, except that we treat the
1655          --  formals as additional visible components.
1656
1657          Gen_Decl := Unit_Declaration_Node (Gen_Unit);
1658
1659          if In_Extended_Main_Source_Unit (N) then
1660             Set_Is_Instantiated (Gen_Unit);
1661             Generate_Reference  (Gen_Unit, N);
1662          end if;
1663
1664          Formal := New_Copy (Pack_Id);
1665          New_N :=
1666            Copy_Generic_Node
1667              (Original_Node (Gen_Decl), Empty, Instantiating => True);
1668          Rewrite (N, New_N);
1669          Set_Defining_Unit_Name (Specification (New_N), Formal);
1670          Set_Instance_Env (Gen_Unit, Formal);
1671
1672          Enter_Name (Formal);
1673          Set_Ekind  (Formal, E_Generic_Package);
1674          Set_Etype  (Formal, Standard_Void_Type);
1675          Set_Inner_Instances (Formal, New_Elmt_List);
1676          New_Scope  (Formal);
1677
1678          --  Within the formal, the name of the generic package is a renaming
1679          --  of the formal (as for a regular instantiation).
1680
1681          Renaming := Make_Package_Renaming_Declaration (Loc,
1682              Defining_Unit_Name =>
1683                Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
1684              Name => New_Reference_To (Formal, Loc));
1685
1686          if Present (Visible_Declarations (Specification (N))) then
1687             Prepend (Renaming, To => Visible_Declarations (Specification (N)));
1688          elsif Present (Private_Declarations (Specification (N))) then
1689             Prepend (Renaming, To => Private_Declarations (Specification (N)));
1690          end if;
1691
1692          if Is_Child_Unit (Gen_Unit)
1693            and then Parent_Installed
1694          then
1695             --  Similarly, we have to make the name of the formal visible in
1696             --  the parent instance, to resolve properly fully qualified names
1697             --  that may appear in the generic unit. The parent instance has
1698             --  been placed on the scope stack ahead of the current scope.
1699
1700             Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity;
1701
1702             Renaming_In_Par :=
1703               Make_Defining_Identifier (Loc, Chars (Gen_Unit));
1704             Set_Ekind (Renaming_In_Par, E_Package);
1705             Set_Etype (Renaming_In_Par, Standard_Void_Type);
1706             Set_Scope (Renaming_In_Par, Parent_Instance);
1707             Set_Parent (Renaming_In_Par, Parent (Formal));
1708             Set_Renamed_Object (Renaming_In_Par, Formal);
1709             Append_Entity (Renaming_In_Par, Parent_Instance);
1710          end if;
1711
1712          Analyze_Generic_Formal_Part (N);
1713          Analyze (Specification (N));
1714          End_Package_Scope (Formal);
1715
1716          if Parent_Installed then
1717             Remove_Parent;
1718          end if;
1719
1720          Restore_Env;
1721
1722          --  Inside the generic unit, the formal package is a regular
1723          --  package, but no body is needed for it. Note that after
1724          --  instantiation, the defining_unit_name we need is in the
1725          --  new tree and not in the original. (see Package_Instantiation).
1726          --  A generic formal package is an instance, and can be used as
1727          --  an actual for an inner instance. Mark its generic parent.
1728
1729          Set_Ekind (Formal, E_Package);
1730          Set_Generic_Parent (Specification (N), Gen_Unit);
1731          Set_Has_Completion (Formal, True);
1732
1733          Set_Ekind (Pack_Id, E_Package);
1734          Set_Etype (Pack_Id, Standard_Void_Type);
1735          Set_Scope (Pack_Id, Scope (Formal));
1736          Set_Has_Completion (Pack_Id, True);
1737       end if;
1738    end Analyze_Formal_Package;
1739
1740    ---------------------------------
1741    -- Analyze_Formal_Private_Type --
1742    ---------------------------------
1743
1744    procedure Analyze_Formal_Private_Type
1745      (N   : Node_Id;
1746       T   : Entity_Id;
1747       Def : Node_Id)
1748    is
1749    begin
1750       New_Private_Type (N, T, Def);
1751
1752       --  Set the size to an arbitrary but legal value.
1753
1754       Set_Size_Info (T, Standard_Integer);
1755       Set_RM_Size   (T, RM_Size (Standard_Integer));
1756    end Analyze_Formal_Private_Type;
1757
1758    ----------------------------------------
1759    -- Analyze_Formal_Signed_Integer_Type --
1760    ----------------------------------------
1761
1762    procedure Analyze_Formal_Signed_Integer_Type
1763      (T   : Entity_Id;
1764       Def : Node_Id)
1765    is
1766       Base : constant Entity_Id :=
1767                New_Internal_Entity
1768                  (E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G');
1769
1770    begin
1771       Enter_Name (T);
1772
1773       Set_Ekind        (T, E_Signed_Integer_Subtype);
1774       Set_Etype        (T, Base);
1775       Set_Size_Info    (T, Standard_Integer);
1776       Set_RM_Size      (T, RM_Size (Standard_Integer));
1777       Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
1778
1779       Set_Is_Generic_Type (Base);
1780       Set_Size_Info       (Base, Standard_Integer);
1781       Set_RM_Size         (Base, RM_Size (Standard_Integer));
1782       Set_Etype           (Base, Base);
1783       Set_Scalar_Range    (Base, Scalar_Range (Standard_Integer));
1784       Set_Parent          (Base, Parent (Def));
1785    end Analyze_Formal_Signed_Integer_Type;
1786
1787    -------------------------------
1788    -- Analyze_Formal_Subprogram --
1789    -------------------------------
1790
1791    procedure Analyze_Formal_Subprogram (N : Node_Id) is
1792       Spec : constant Node_Id   := Specification (N);
1793       Def  : constant Node_Id   := Default_Name (N);
1794       Nam  : constant Entity_Id := Defining_Unit_Name (Spec);
1795       Subp : Entity_Id;
1796
1797    begin
1798       if Nam = Error then
1799          return;
1800       end if;
1801
1802       if Nkind (Nam) = N_Defining_Program_Unit_Name then
1803          Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
1804          return;
1805       end if;
1806
1807       Analyze_Subprogram_Declaration (N);
1808       Set_Is_Formal_Subprogram (Nam);
1809       Set_Has_Completion (Nam);
1810
1811       --  Default name is resolved at the point of instantiation
1812
1813       if Box_Present (N) then
1814          null;
1815
1816       --  Else default is bound at the point of generic declaration
1817
1818       elsif Present (Def) then
1819          if Nkind (Def) = N_Operator_Symbol then
1820             Find_Direct_Name (Def);
1821
1822          elsif Nkind (Def) /= N_Attribute_Reference then
1823             Analyze (Def);
1824
1825          else
1826             --  For an attribute reference, analyze the prefix and verify
1827             --  that it has the proper profile for the subprogram.
1828
1829             Analyze (Prefix (Def));
1830             Valid_Default_Attribute (Nam, Def);
1831             return;
1832          end if;
1833
1834          --  Default name may be overloaded, in which case the interpretation
1835          --  with the correct profile must be  selected, as for a renaming.
1836
1837          if Etype (Def) = Any_Type then
1838             return;
1839
1840          elsif Nkind (Def) = N_Selected_Component then
1841             Subp := Entity (Selector_Name (Def));
1842
1843             if Ekind (Subp) /= E_Entry then
1844                Error_Msg_N ("expect valid subprogram name as default", Def);
1845                return;
1846             end if;
1847
1848          elsif Nkind (Def) = N_Indexed_Component then
1849
1850             if  Nkind (Prefix (Def)) /= N_Selected_Component then
1851                Error_Msg_N ("expect valid subprogram name as default", Def);
1852                return;
1853
1854             else
1855                Subp := Entity (Selector_Name (Prefix (Def)));
1856
1857                if Ekind (Subp) /= E_Entry_Family then
1858                   Error_Msg_N ("expect valid subprogram name as default", Def);
1859                   return;
1860                end if;
1861             end if;
1862
1863          elsif Nkind (Def) = N_Character_Literal then
1864
1865             --  Needs some type checks: subprogram should be parameterless???
1866
1867             Resolve (Def, (Etype (Nam)));
1868
1869          elsif not Is_Entity_Name (Def)
1870            or else not Is_Overloadable (Entity (Def))
1871          then
1872             Error_Msg_N ("expect valid subprogram name as default", Def);
1873             return;
1874
1875          elsif not Is_Overloaded (Def) then
1876             Subp := Entity (Def);
1877
1878             if Subp = Nam then
1879                Error_Msg_N ("premature usage of formal subprogram", Def);
1880
1881             elsif not Entity_Matches_Spec (Subp, Nam) then
1882                Error_Msg_N ("no visible entity matches specification", Def);
1883             end if;
1884
1885          else
1886             declare
1887                I   : Interp_Index;
1888                I1  : Interp_Index := 0;
1889                It  : Interp;
1890                It1 : Interp;
1891
1892             begin
1893                Subp := Any_Id;
1894                Get_First_Interp (Def, I, It);
1895                while Present (It.Nam) loop
1896
1897                   if Entity_Matches_Spec (It.Nam, Nam) then
1898                      if Subp /= Any_Id then
1899                         It1 := Disambiguate (Def, I1, I, Etype (Subp));
1900
1901                         if It1 = No_Interp then
1902                            Error_Msg_N ("ambiguous default subprogram", Def);
1903                         else
1904                            Subp := It1.Nam;
1905                         end if;
1906
1907                         exit;
1908
1909                      else
1910                         I1  := I;
1911                         Subp := It.Nam;
1912                      end if;
1913                   end if;
1914
1915                   Get_Next_Interp (I, It);
1916                end loop;
1917             end;
1918
1919             if Subp /= Any_Id then
1920                Set_Entity (Def, Subp);
1921
1922                if Subp = Nam then
1923                   Error_Msg_N ("premature usage of formal subprogram", Def);
1924
1925                elsif Ekind (Subp) /= E_Operator then
1926                   Check_Mode_Conformant (Subp, Nam);
1927                end if;
1928
1929             else
1930                Error_Msg_N ("no visible subprogram matches specification", N);
1931             end if;
1932          end if;
1933       end if;
1934    end Analyze_Formal_Subprogram;
1935
1936    -------------------------------------
1937    -- Analyze_Formal_Type_Declaration --
1938    -------------------------------------
1939
1940    procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
1941       Def : constant Node_Id := Formal_Type_Definition (N);
1942       T   : Entity_Id;
1943
1944    begin
1945       T := Defining_Identifier (N);
1946
1947       if Present (Discriminant_Specifications (N))
1948         and then Nkind (Def) /= N_Formal_Private_Type_Definition
1949       then
1950          Error_Msg_N
1951            ("discriminants not allowed for this formal type",
1952             Defining_Identifier (First (Discriminant_Specifications (N))));
1953       end if;
1954
1955       --  Enter the new name, and branch to specific routine.
1956
1957       case Nkind (Def) is
1958          when N_Formal_Private_Type_Definition         =>
1959             Analyze_Formal_Private_Type (N, T, Def);
1960
1961          when N_Formal_Derived_Type_Definition         =>
1962             Analyze_Formal_Derived_Type (N, T, Def);
1963
1964          when N_Formal_Discrete_Type_Definition        =>
1965             Analyze_Formal_Discrete_Type (T, Def);
1966
1967          when N_Formal_Signed_Integer_Type_Definition  =>
1968             Analyze_Formal_Signed_Integer_Type (T, Def);
1969
1970          when N_Formal_Modular_Type_Definition         =>
1971             Analyze_Formal_Modular_Type (T, Def);
1972
1973          when N_Formal_Floating_Point_Definition       =>
1974             Analyze_Formal_Floating_Type (T, Def);
1975
1976          when N_Formal_Ordinary_Fixed_Point_Definition =>
1977             Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
1978
1979          when N_Formal_Decimal_Fixed_Point_Definition  =>
1980             Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
1981
1982          when N_Array_Type_Definition =>
1983             Analyze_Formal_Array_Type (T, Def);
1984
1985          when N_Access_To_Object_Definition            |
1986               N_Access_Function_Definition             |
1987               N_Access_Procedure_Definition            =>
1988             Analyze_Generic_Access_Type (T, Def);
1989
1990          when N_Error                                  =>
1991             null;
1992
1993          when others                                   =>
1994             raise Program_Error;
1995
1996       end case;
1997
1998       Set_Is_Generic_Type (T);
1999    end Analyze_Formal_Type_Declaration;
2000
2001    ------------------------------------
2002    -- Analyze_Function_Instantiation --
2003    ------------------------------------
2004
2005    procedure Analyze_Function_Instantiation (N : Node_Id) is
2006    begin
2007       Analyze_Subprogram_Instantiation (N, E_Function);
2008    end Analyze_Function_Instantiation;
2009
2010    ---------------------------------
2011    -- Analyze_Generic_Access_Type --
2012    ---------------------------------
2013
2014    procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is
2015    begin
2016       Enter_Name (T);
2017
2018       if Nkind (Def) = N_Access_To_Object_Definition then
2019          Access_Type_Declaration (T, Def);
2020
2021          if Is_Incomplete_Or_Private_Type (Designated_Type (T))
2022            and then No (Full_View (Designated_Type (T)))
2023            and then not Is_Generic_Type (Designated_Type (T))
2024          then
2025             Error_Msg_N ("premature usage of incomplete type", Def);
2026
2027          elsif Is_Internal (Designated_Type (T)) then
2028             Error_Msg_N
2029               ("only a subtype mark is allowed in a formal", Def);
2030          end if;
2031
2032       else
2033          Access_Subprogram_Declaration (T, Def);
2034       end if;
2035    end Analyze_Generic_Access_Type;
2036
2037    ---------------------------------
2038    -- Analyze_Generic_Formal_Part --
2039    ---------------------------------
2040
2041    procedure Analyze_Generic_Formal_Part (N : Node_Id) is
2042       Gen_Parm_Decl : Node_Id;
2043
2044    begin
2045       --  The generic formals are processed in the scope of the generic
2046       --  unit, where they are immediately visible. The scope is installed
2047       --  by the caller.
2048
2049       Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
2050
2051       while Present (Gen_Parm_Decl) loop
2052          Analyze (Gen_Parm_Decl);
2053          Next (Gen_Parm_Decl);
2054       end loop;
2055
2056       Generate_Reference_To_Generic_Formals (Current_Scope);
2057    end Analyze_Generic_Formal_Part;
2058
2059    ------------------------------------------
2060    -- Analyze_Generic_Package_Declaration  --
2061    ------------------------------------------
2062
2063    procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
2064       Loc         : constant Source_Ptr := Sloc (N);
2065       Id          : Entity_Id;
2066       New_N       : Node_Id;
2067       Save_Parent : Node_Id;
2068       Renaming    : Node_Id;
2069       Decls       : constant List_Id :=
2070                       Visible_Declarations (Specification (N));
2071       Decl        : Node_Id;
2072
2073    begin
2074       --  We introduce a renaming of the enclosing package, to have a usable
2075       --  entity as the prefix of an expanded name for a local entity of the
2076       --  form Par.P.Q, where P is the generic package. This is because a local
2077       --  entity named P may hide it, so that the usual visibility rules in
2078       --  the instance will not resolve properly.
2079
2080       Renaming :=
2081         Make_Package_Renaming_Declaration (Loc,
2082           Defining_Unit_Name =>
2083             Make_Defining_Identifier (Loc,
2084              Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
2085           Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
2086
2087       if Present (Decls) then
2088          Decl := First (Decls);
2089          while Present (Decl)
2090            and then Nkind (Decl) = N_Pragma
2091          loop
2092             Next (Decl);
2093          end loop;
2094
2095          if Present (Decl) then
2096             Insert_Before (Decl, Renaming);
2097          else
2098             Append (Renaming, Visible_Declarations (Specification (N)));
2099          end if;
2100
2101       else
2102          Set_Visible_Declarations (Specification (N), New_List (Renaming));
2103       end if;
2104
2105       --  Create copy of generic unit, and save for instantiation.
2106       --  If the unit is a child unit, do not copy the specifications
2107       --  for the parent, which are not part of the generic tree.
2108
2109       Save_Parent := Parent_Spec (N);
2110       Set_Parent_Spec (N, Empty);
2111
2112       New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
2113       Set_Parent_Spec (New_N, Save_Parent);
2114       Rewrite (N, New_N);
2115       Id := Defining_Entity (N);
2116       Generate_Definition (Id);
2117
2118       --  Expansion is not applied to generic units.
2119
2120       Start_Generic;
2121
2122       Enter_Name (Id);
2123       Set_Ekind (Id, E_Generic_Package);
2124       Set_Etype (Id, Standard_Void_Type);
2125       New_Scope (Id);
2126       Enter_Generic_Scope (Id);
2127       Set_Inner_Instances (Id, New_Elmt_List);
2128
2129       Set_Categorization_From_Pragmas (N);
2130       Set_Is_Pure (Id, Is_Pure (Current_Scope));
2131
2132       --  Link the declaration of the generic homonym in the generic copy
2133       --  to the package it renames, so that it is always resolved properly.
2134
2135       Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming));
2136       Set_Entity (Associated_Node (Name (Renaming)), Id);
2137
2138       --  For a library unit, we have reconstructed the entity for the
2139       --  unit, and must reset it in the library tables.
2140
2141       if Nkind (Parent (N)) = N_Compilation_Unit then
2142          Set_Cunit_Entity (Current_Sem_Unit, Id);
2143       end if;
2144
2145       Analyze_Generic_Formal_Part (N);
2146
2147       --  After processing the generic formals, analysis proceeds
2148       --  as for a non-generic package.
2149
2150       Analyze (Specification (N));
2151
2152       Validate_Categorization_Dependency (N, Id);
2153
2154       End_Generic;
2155
2156       End_Package_Scope (Id);
2157       Exit_Generic_Scope (Id);
2158
2159       if Nkind (Parent (N)) /= N_Compilation_Unit then
2160          Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N)));
2161          Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N)));
2162          Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N));
2163
2164       else
2165          Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
2166          Validate_RT_RAT_Component (N);
2167
2168          --  If this is a spec without a body, check that generic parameters
2169          --  are referenced.
2170
2171          if not Body_Required (Parent (N)) then
2172             Check_References (Id);
2173          end if;
2174       end if;
2175    end Analyze_Generic_Package_Declaration;
2176
2177    --------------------------------------------
2178    -- Analyze_Generic_Subprogram_Declaration --
2179    --------------------------------------------
2180
2181    procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
2182       Spec        : Node_Id;
2183       Id          : Entity_Id;
2184       Formals     : List_Id;
2185       New_N       : Node_Id;
2186       Save_Parent : Node_Id;
2187
2188    begin
2189       --  Create copy of generic unit,and save for instantiation.
2190       --  If the unit is a child unit, do not copy the specifications
2191       --  for the parent, which are not part of the generic tree.
2192
2193       Save_Parent := Parent_Spec (N);
2194       Set_Parent_Spec (N, Empty);
2195
2196       New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
2197       Set_Parent_Spec (New_N, Save_Parent);
2198       Rewrite (N, New_N);
2199
2200       Spec := Specification (N);
2201       Id := Defining_Entity (Spec);
2202       Generate_Definition (Id);
2203
2204       if Nkind (Id) = N_Defining_Operator_Symbol then
2205          Error_Msg_N
2206            ("operator symbol not allowed for generic subprogram", Id);
2207       end if;
2208
2209       Start_Generic;
2210
2211       Enter_Name (Id);
2212
2213       Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
2214       New_Scope (Id);
2215       Enter_Generic_Scope (Id);
2216       Set_Inner_Instances (Id, New_Elmt_List);
2217       Set_Is_Pure (Id, Is_Pure (Current_Scope));
2218
2219       Analyze_Generic_Formal_Part (N);
2220
2221       Formals := Parameter_Specifications (Spec);
2222
2223       if Present (Formals) then
2224          Process_Formals (Formals, Spec);
2225       end if;
2226
2227       if Nkind (Spec) = N_Function_Specification then
2228          Set_Ekind (Id, E_Generic_Function);
2229          Find_Type (Subtype_Mark (Spec));
2230          Set_Etype (Id, Entity (Subtype_Mark (Spec)));
2231       else
2232          Set_Ekind (Id, E_Generic_Procedure);
2233          Set_Etype (Id, Standard_Void_Type);
2234       end if;
2235
2236       --  For a library unit, we have reconstructed the entity for the
2237       --  unit, and must reset it in the library tables. We also need
2238       --  to make sure that Body_Required is set properly in the original
2239       --  compilation unit node.
2240
2241       if Nkind (Parent (N)) = N_Compilation_Unit then
2242          Set_Cunit_Entity (Current_Sem_Unit, Id);
2243          Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
2244       end if;
2245
2246       Set_Categorization_From_Pragmas (N);
2247       Validate_Categorization_Dependency (N, Id);
2248
2249       Save_Global_References (Original_Node (N));
2250
2251       End_Generic;
2252       End_Scope;
2253       Exit_Generic_Scope (Id);
2254       Generate_Reference_To_Formals (Id);
2255    end Analyze_Generic_Subprogram_Declaration;
2256
2257    -----------------------------------
2258    -- Analyze_Package_Instantiation --
2259    -----------------------------------
2260
2261    --  Note: this procedure is also used for formal package declarations,
2262    --  in which case the argument N is an N_Formal_Package_Declaration
2263    --  node. This should really be noted in the spec! ???
2264
2265    procedure Analyze_Package_Instantiation (N : Node_Id) is
2266       Loc    : constant Source_Ptr := Sloc (N);
2267       Gen_Id : constant Node_Id    := Name (N);
2268
2269       Act_Decl      : Node_Id;
2270       Act_Decl_Name : Node_Id;
2271       Act_Decl_Id   : Entity_Id;
2272       Act_Spec      : Node_Id;
2273       Act_Tree      : Node_Id;
2274
2275       Gen_Decl : Node_Id;
2276       Gen_Unit : Entity_Id;
2277
2278       Is_Actual_Pack : constant Boolean :=
2279                          Is_Internal (Defining_Entity (N));
2280
2281       Parent_Installed : Boolean := False;
2282       Renaming_List    : List_Id;
2283       Unit_Renaming    : Node_Id;
2284       Needs_Body       : Boolean;
2285       Inline_Now       : Boolean := False;
2286
2287       procedure Delay_Descriptors (E : Entity_Id);
2288       --  Delay generation of subprogram descriptors for given entity
2289
2290       function Might_Inline_Subp return Boolean;
2291       --  If inlining is active and the generic contains inlined subprograms,
2292       --  we instantiate the body. This may cause superfluous instantiations,
2293       --  but it is simpler than detecting the need for the body at the point
2294       --  of inlining, when the context of the instance is not available.
2295
2296       -----------------------
2297       -- Delay_Descriptors --
2298       -----------------------
2299
2300       procedure Delay_Descriptors (E : Entity_Id) is
2301       begin
2302          if not Delay_Subprogram_Descriptors (E) then
2303             Set_Delay_Subprogram_Descriptors (E);
2304             Pending_Descriptor.Increment_Last;
2305             Pending_Descriptor.Table (Pending_Descriptor.Last) := E;
2306          end if;
2307       end Delay_Descriptors;
2308
2309       -----------------------
2310       -- Might_Inline_Subp --
2311       -----------------------
2312
2313       function Might_Inline_Subp return Boolean is
2314          E : Entity_Id;
2315
2316       begin
2317          if not Inline_Processing_Required then
2318             return False;
2319
2320          else
2321             E := First_Entity (Gen_Unit);
2322
2323             while Present (E) loop
2324
2325                if Is_Subprogram (E)
2326                  and then Is_Inlined (E)
2327                then
2328                   return True;
2329                end if;
2330
2331                Next_Entity (E);
2332             end loop;
2333          end if;
2334
2335          return False;
2336       end Might_Inline_Subp;
2337
2338    --  Start of processing for Analyze_Package_Instantiation
2339
2340    begin
2341       --  Very first thing: apply the special kludge for Text_IO processing
2342       --  in case we are instantiating one of the children of [Wide_]Text_IO.
2343
2344       Text_IO_Kludge (Name (N));
2345
2346       --  Make node global for error reporting.
2347
2348       Instantiation_Node := N;
2349
2350       --  Case of instantiation of a generic package
2351
2352       if Nkind (N) = N_Package_Instantiation then
2353          Act_Decl_Id := New_Copy (Defining_Entity (N));
2354          Set_Comes_From_Source (Act_Decl_Id, True);
2355
2356          if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
2357             Act_Decl_Name :=
2358               Make_Defining_Program_Unit_Name (Loc,
2359                 Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
2360                 Defining_Identifier => Act_Decl_Id);
2361          else
2362             Act_Decl_Name :=  Act_Decl_Id;
2363          end if;
2364
2365       --  Case of instantiation of a formal package
2366
2367       else
2368          Act_Decl_Id   := Defining_Identifier (N);
2369          Act_Decl_Name := Act_Decl_Id;
2370       end if;
2371
2372       Generate_Definition (Act_Decl_Id);
2373       Pre_Analyze_Actuals (N);
2374
2375       Init_Env;
2376       Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
2377       Gen_Unit := Entity (Gen_Id);
2378
2379       --  Verify that it is the name of a generic package
2380
2381       if Etype (Gen_Unit) = Any_Type then
2382          Restore_Env;
2383          return;
2384
2385       elsif Ekind (Gen_Unit) /= E_Generic_Package then
2386
2387          --  Ada 2005 (AI-50217): Cannot use instance in limited with_clause
2388
2389          if From_With_Type (Gen_Unit) then
2390             Error_Msg_N
2391               ("cannot instantiate a limited withed package", Gen_Id);
2392          else
2393             Error_Msg_N
2394               ("expect name of generic package in instantiation", Gen_Id);
2395          end if;
2396
2397          Restore_Env;
2398          return;
2399       end if;
2400
2401       if In_Extended_Main_Source_Unit (N) then
2402          Set_Is_Instantiated (Gen_Unit);
2403          Generate_Reference  (Gen_Unit, N);
2404
2405          if Present (Renamed_Object (Gen_Unit)) then
2406             Set_Is_Instantiated (Renamed_Object (Gen_Unit));
2407             Generate_Reference  (Renamed_Object (Gen_Unit), N);
2408          end if;
2409       end if;
2410
2411       if Nkind (Gen_Id) = N_Identifier
2412         and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
2413       then
2414          Error_Msg_NE
2415            ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
2416
2417       elsif Nkind (Gen_Id) = N_Expanded_Name
2418         and then Is_Child_Unit (Gen_Unit)
2419         and then Nkind (Prefix (Gen_Id)) = N_Identifier
2420         and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
2421       then
2422          Error_Msg_N
2423            ("& is hidden within declaration of instance ", Prefix (Gen_Id));
2424       end if;
2425
2426       Set_Entity (Gen_Id, Gen_Unit);
2427
2428       --  If generic is a renaming, get original generic unit.
2429
2430       if Present (Renamed_Object (Gen_Unit))
2431         and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
2432       then
2433          Gen_Unit := Renamed_Object (Gen_Unit);
2434       end if;
2435
2436       --  Verify that there are no circular instantiations.
2437
2438       if In_Open_Scopes (Gen_Unit) then
2439          Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
2440          Restore_Env;
2441          return;
2442
2443       elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
2444          Error_Msg_Node_2 := Current_Scope;
2445          Error_Msg_NE
2446            ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
2447          Circularity_Detected := True;
2448          Restore_Env;
2449          return;
2450
2451       else
2452          Set_Instance_Env (Gen_Unit, Act_Decl_Id);
2453          Gen_Decl := Unit_Declaration_Node (Gen_Unit);
2454
2455          --  Initialize renamings map, for error checking, and the list
2456          --  that holds private entities whose views have changed between
2457          --  generic definition and instantiation. If this is the instance
2458          --  created to validate an actual package, the instantiation
2459          --  environment is that of the enclosing instance.
2460
2461          Generic_Renamings.Set_Last (0);
2462          Generic_Renamings_HTable.Reset;
2463
2464          Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
2465
2466          --  Copy original generic tree, to produce text for instantiation.
2467
2468          Act_Tree :=
2469            Copy_Generic_Node
2470              (Original_Node (Gen_Decl), Empty, Instantiating => True);
2471
2472          Act_Spec := Specification (Act_Tree);
2473
2474          --  If this is the instance created to validate an actual package,
2475          --  only the formals matter, do not examine the package spec itself.
2476
2477          if Is_Actual_Pack then
2478             Set_Visible_Declarations (Act_Spec, New_List);
2479             Set_Private_Declarations (Act_Spec, New_List);
2480          end if;
2481
2482          Renaming_List :=
2483            Analyze_Associations
2484              (N,
2485               Generic_Formal_Declarations (Act_Tree),
2486               Generic_Formal_Declarations (Gen_Decl));
2487
2488          Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
2489          Set_Is_Generic_Instance (Act_Decl_Id);
2490
2491          Set_Generic_Parent (Act_Spec, Gen_Unit);
2492
2493          --  References to the generic in its own declaration or its body
2494          --  are references to the instance. Add a renaming declaration for
2495          --  the generic unit itself. This declaration, as well as the renaming
2496          --  declarations for the generic formals, must remain private to the
2497          --  unit: the formals, because this is the language semantics, and
2498          --  the unit because its use is an artifact of the implementation.
2499
2500          Unit_Renaming :=
2501            Make_Package_Renaming_Declaration (Loc,
2502              Defining_Unit_Name =>
2503                Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
2504              Name => New_Reference_To (Act_Decl_Id, Loc));
2505
2506          Append (Unit_Renaming, Renaming_List);
2507
2508          --  The renaming declarations are the first local declarations of
2509          --  the new unit.
2510
2511          if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then
2512             Insert_List_Before
2513               (First (Visible_Declarations (Act_Spec)), Renaming_List);
2514          else
2515             Set_Visible_Declarations (Act_Spec, Renaming_List);
2516          end if;
2517
2518          Act_Decl :=
2519            Make_Package_Declaration (Loc,
2520              Specification => Act_Spec);
2521
2522          --  Save the instantiation node, for subsequent instantiation
2523          --  of the body, if there is one and we are generating code for
2524          --  the current unit. Mark the unit as having a body, to avoid
2525          --  a premature error message.
2526
2527          --  We instantiate the body if we are generating code, if we are
2528          --  generating cross-reference information, or if we are building
2529          --  trees for ASIS use.
2530
2531          declare
2532             Enclosing_Body_Present : Boolean := False;
2533             --  If the generic unit is not a compilation unit, then a body
2534             --  may be present in its parent even if none is required. We
2535             --  create a tentative pending instantiation for the body, which
2536             --  will be discarded if none is actually present.
2537
2538             Scop : Entity_Id;
2539
2540          begin
2541             if Scope (Gen_Unit) /= Standard_Standard
2542               and then not Is_Child_Unit (Gen_Unit)
2543             then
2544                Scop := Scope (Gen_Unit);
2545
2546                while Present (Scop)
2547                  and then Scop /= Standard_Standard
2548                loop
2549                   if Unit_Requires_Body (Scop) then
2550                      Enclosing_Body_Present := True;
2551                      exit;
2552
2553                   elsif In_Open_Scopes (Scop)
2554                     and then In_Package_Body (Scop)
2555                   then
2556                      Enclosing_Body_Present := True;
2557                      exit;
2558                   end if;
2559
2560                   exit when Is_Compilation_Unit (Scop);
2561                   Scop := Scope (Scop);
2562                end loop;
2563             end if;
2564
2565             --  If front-end inlining is enabled, and this is a unit for which
2566             --  code will be generated, we instantiate the body at once.
2567             --  This is done if the instance is not the main unit, and if the
2568             --  generic is not a child unit of another generic, to avoid scope
2569             --  problems and the reinstallation of parent instances.
2570
2571             if Front_End_Inlining
2572               and then Expander_Active
2573               and then (not Is_Child_Unit (Gen_Unit)
2574                          or else not Is_Generic_Unit (Scope (Gen_Unit)))
2575               and then Is_In_Main_Unit (N)
2576               and then Nkind (Parent (N)) /= N_Compilation_Unit
2577               and then Might_Inline_Subp
2578               and then not Is_Actual_Pack
2579             then
2580                Inline_Now := True;
2581             end if;
2582
2583             Needs_Body :=
2584               (Unit_Requires_Body (Gen_Unit)
2585                   or else Enclosing_Body_Present
2586                   or else Present (Corresponding_Body (Gen_Decl)))
2587                 and then (Is_In_Main_Unit (N)
2588                            or else Might_Inline_Subp)
2589                 and then not Is_Actual_Pack
2590                 and then not Inline_Now
2591
2592                 and then (Operating_Mode = Generate_Code
2593                             or else (Operating_Mode = Check_Semantics
2594                                       and then ASIS_Mode));
2595
2596             --  If front_end_inlining is enabled, do not instantiate a
2597             --  body if within a generic context.
2598
2599             if Front_End_Inlining
2600               and then not Expander_Active
2601             then
2602                Needs_Body := False;
2603             end if;
2604
2605             --  If the current context is generic, and the package being
2606             --  instantiated is declared within a formal package, there
2607             --  is no body to instantiate until the enclosing generic is
2608             --  instantiated, and there is an actual for the formal
2609             --  package. If the formal package has parameters, we build a
2610             --  regular package instance for it, that preceeds the original
2611             --  formal package declaration.
2612
2613             if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
2614                declare
2615                   Decl : constant Node_Id :=
2616                            Original_Node
2617                              (Unit_Declaration_Node (Scope (Gen_Unit)));
2618                begin
2619                   if Nkind (Decl) = N_Formal_Package_Declaration
2620                     or else (Nkind (Decl) = N_Package_Declaration
2621                       and then Is_List_Member (Decl)
2622                       and then Present (Next (Decl))
2623                       and then
2624                         Nkind (Next (Decl)) = N_Formal_Package_Declaration)
2625                   then
2626                      Needs_Body := False;
2627                   end if;
2628                end;
2629             end if;
2630          end;
2631
2632          --  If we are generating the calling stubs from the instantiation
2633          --  of a generic RCI package, we will not use the body of the
2634          --  generic package.
2635
2636          if Distribution_Stub_Mode = Generate_Caller_Stub_Body
2637            and then Is_Compilation_Unit (Defining_Entity (N))
2638          then
2639             Needs_Body := False;
2640          end if;
2641
2642          if Needs_Body then
2643
2644             --  Here is a defence against a ludicrous number of instantiations
2645             --  caused by a circular set of instantiation attempts.
2646
2647             if Pending_Instantiations.Last >
2648                  Hostparm.Max_Instantiations
2649             then
2650                Error_Msg_N ("too many instantiations", N);
2651                raise Unrecoverable_Error;
2652             end if;
2653
2654             --  Indicate that the enclosing scopes contain an instantiation,
2655             --  and that cleanup actions should be delayed until after the
2656             --  instance body is expanded.
2657
2658             Check_Forward_Instantiation (Gen_Decl);
2659             if Nkind (N) = N_Package_Instantiation then
2660                declare
2661                   Enclosing_Master : Entity_Id := Current_Scope;
2662
2663                begin
2664                   while Enclosing_Master /= Standard_Standard loop
2665
2666                      if Ekind (Enclosing_Master) = E_Package then
2667                         if Is_Compilation_Unit (Enclosing_Master) then
2668                            if In_Package_Body (Enclosing_Master) then
2669                               Delay_Descriptors
2670                                 (Body_Entity (Enclosing_Master));
2671                            else
2672                               Delay_Descriptors
2673                                 (Enclosing_Master);
2674                            end if;
2675
2676                            exit;
2677
2678                         else
2679                            Enclosing_Master := Scope (Enclosing_Master);
2680                         end if;
2681
2682                      elsif Ekind (Enclosing_Master) = E_Generic_Package then
2683                         Enclosing_Master := Scope (Enclosing_Master);
2684
2685                      elsif Is_Generic_Subprogram (Enclosing_Master)
2686                        or else Ekind (Enclosing_Master) = E_Void
2687                      then
2688                         --  Cleanup actions will eventually be performed on
2689                         --  the enclosing instance, if any. enclosing scope
2690                         --  is void in the formal part of a generic subp.
2691
2692                         exit;
2693
2694                      else
2695                         if Ekind (Enclosing_Master) = E_Entry
2696                           and then
2697                             Ekind (Scope (Enclosing_Master)) = E_Protected_Type
2698                         then
2699                            Enclosing_Master :=
2700                              Protected_Body_Subprogram (Enclosing_Master);
2701                         end if;
2702
2703                         Set_Delay_Cleanups (Enclosing_Master);
2704
2705                         while Ekind (Enclosing_Master) = E_Block loop
2706                            Enclosing_Master := Scope (Enclosing_Master);
2707                         end loop;
2708
2709                         if Is_Subprogram (Enclosing_Master) then
2710                            Delay_Descriptors (Enclosing_Master);
2711
2712                         elsif Is_Task_Type (Enclosing_Master) then
2713                            declare
2714                               TBP : constant Node_Id :=
2715                                       Get_Task_Body_Procedure
2716                                         (Enclosing_Master);
2717
2718                            begin
2719                               if Present (TBP) then
2720                                  Delay_Descriptors  (TBP);
2721                                  Set_Delay_Cleanups (TBP);
2722                               end if;
2723                            end;
2724                         end if;
2725
2726                         exit;
2727                      end if;
2728                   end loop;
2729                end;
2730
2731                --  Make entry in table
2732
2733                Pending_Instantiations.Increment_Last;
2734                Pending_Instantiations.Table (Pending_Instantiations.Last) :=
2735                  (N, Act_Decl, Expander_Active, Current_Sem_Unit);
2736             end if;
2737          end if;
2738
2739          Set_Categorization_From_Pragmas (Act_Decl);
2740
2741          if Parent_Installed then
2742             Hide_Current_Scope;
2743          end if;
2744
2745          Set_Instance_Spec (N, Act_Decl);
2746
2747          --  If not a compilation unit, insert the package declaration
2748          --  before the original instantiation node.
2749
2750          if Nkind (Parent (N)) /= N_Compilation_Unit then
2751             Mark_Rewrite_Insertion (Act_Decl);
2752             Insert_Before (N, Act_Decl);
2753             Analyze (Act_Decl);
2754
2755          --  For an instantiation that is a compilation unit, place
2756          --  declaration on current node so context is complete
2757          --  for analysis (including nested instantiations). It this
2758          --  is the main unit, the declaration eventually replaces the
2759          --  instantiation node. If the instance body is later created, it
2760          --  replaces the instance node, and the declation is attached to
2761          --  it (see Build_Instance_Compilation_Unit_Nodes).
2762
2763          else
2764             if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
2765
2766                --  The entity for the current unit is the newly created one,
2767                --  and all semantic information is attached to it.
2768
2769                Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
2770
2771                --  If this is the main unit, replace the main entity as well.
2772
2773                if Current_Sem_Unit = Main_Unit then
2774                   Main_Unit_Entity := Act_Decl_Id;
2775                end if;
2776             end if;
2777
2778             Set_Unit (Parent (N), Act_Decl);
2779             Set_Parent_Spec (Act_Decl, Parent_Spec (N));
2780             Analyze (Act_Decl);
2781             Set_Unit (Parent (N), N);
2782             Set_Body_Required (Parent (N), False);
2783
2784             --  We never need elaboration checks on instantiations, since
2785             --  by definition, the body instantiation is elaborated at the
2786             --  same time as the spec instantiation.
2787
2788             Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
2789             Set_Kill_Elaboration_Checks       (Act_Decl_Id);
2790          end if;
2791
2792          Check_Elab_Instantiation (N);
2793
2794          if ABE_Is_Certain (N) and then Needs_Body then
2795             Pending_Instantiations.Decrement_Last;
2796          end if;
2797          Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
2798
2799          Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
2800            First_Private_Entity (Act_Decl_Id));
2801
2802          --  If the instantiation will receive a body, the unit will
2803          --  be transformed into a package body, and receive its own
2804          --  elaboration entity. Otherwise, the nature of the unit is
2805          --  now a package declaration.
2806
2807          if Nkind (Parent (N)) = N_Compilation_Unit
2808            and then not Needs_Body
2809          then
2810             Rewrite (N, Act_Decl);
2811          end if;
2812
2813          if Present (Corresponding_Body (Gen_Decl))
2814            or else Unit_Requires_Body (Gen_Unit)
2815          then
2816             Set_Has_Completion (Act_Decl_Id);
2817          end if;
2818
2819          Check_Formal_Packages (Act_Decl_Id);
2820
2821          Restore_Private_Views (Act_Decl_Id);
2822
2823          if not Generic_Separately_Compiled (Gen_Unit) then
2824             Inherit_Context (Gen_Decl, N);
2825          end if;
2826
2827          if Parent_Installed then
2828             Remove_Parent;
2829          end if;
2830
2831          Restore_Env;
2832       end if;
2833
2834       Validate_Categorization_Dependency (N, Act_Decl_Id);
2835
2836       --  Check restriction, but skip this if something went wrong in
2837       --  the above analysis, indicated by Act_Decl_Id being void.
2838
2839       if Ekind (Act_Decl_Id) /= E_Void
2840         and then not Is_Library_Level_Entity (Act_Decl_Id)
2841       then
2842          Check_Restriction (No_Local_Allocators, N);
2843       end if;
2844
2845       if Inline_Now then
2846          Inline_Instance_Body (N, Gen_Unit, Act_Decl);
2847       end if;
2848
2849    exception
2850       when Instantiation_Error =>
2851          if Parent_Installed then
2852             Remove_Parent;
2853          end if;
2854    end Analyze_Package_Instantiation;
2855
2856    --------------------------
2857    -- Inline_Instance_Body --
2858    --------------------------
2859
2860    procedure Inline_Instance_Body
2861      (N        : Node_Id;
2862       Gen_Unit : Entity_Id;
2863       Act_Decl : Node_Id)
2864    is
2865       Vis          : Boolean;
2866       Gen_Comp     : constant Entity_Id :=
2867                       Cunit_Entity (Get_Source_Unit (Gen_Unit));
2868       Curr_Comp    : constant Node_Id := Cunit (Current_Sem_Unit);
2869       Curr_Scope   : Entity_Id := Empty;
2870       Curr_Unit    : constant Entity_Id :=
2871                        Cunit_Entity (Current_Sem_Unit);
2872       Removed      : Boolean := False;
2873       Num_Scopes   : Int := 0;
2874       Use_Clauses  : array (1 .. Scope_Stack.Last) of Node_Id;
2875       Instances    : array (1 .. Scope_Stack.Last) of Entity_Id;
2876       Inner_Scopes : array (1 .. Scope_Stack.Last) of Entity_Id;
2877       Num_Inner    : Int := 0;
2878       N_Instances  : Int := 0;
2879       S            : Entity_Id;
2880
2881    begin
2882       --  Case of generic unit defined in another unit. We must remove
2883       --  the complete context of the current unit to install that of
2884       --  the generic.
2885
2886       if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
2887          S := Current_Scope;
2888
2889          while Present (S)
2890            and then S /= Standard_Standard
2891          loop
2892             Num_Scopes := Num_Scopes + 1;
2893
2894             Use_Clauses (Num_Scopes) :=
2895               (Scope_Stack.Table
2896                  (Scope_Stack.Last - Num_Scopes + 1).
2897                     First_Use_Clause);
2898             End_Use_Clauses (Use_Clauses (Num_Scopes));
2899
2900             exit when Is_Generic_Instance (S)
2901               and then (In_Package_Body (S)
2902                           or else Ekind (S) = E_Procedure
2903                           or else Ekind (S) = E_Function);
2904             S := Scope (S);
2905          end loop;
2906
2907          Vis := Is_Immediately_Visible (Gen_Comp);
2908
2909          --  Find and save all enclosing instances
2910
2911          S := Current_Scope;
2912
2913          while Present (S)
2914            and then S /= Standard_Standard
2915          loop
2916             if Is_Generic_Instance (S) then
2917                N_Instances := N_Instances + 1;
2918                Instances (N_Instances) := S;
2919
2920                exit when In_Package_Body (S);
2921             end if;
2922
2923             S := Scope (S);
2924          end loop;
2925
2926          --  Remove context of current compilation unit, unless we
2927          --  are within a nested package instantiation, in which case
2928          --  the context has been removed previously.
2929
2930          --  If current scope is the body of a child unit, remove context
2931          --  of spec as well.
2932
2933          S := Current_Scope;
2934
2935          while Present (S)
2936            and then S /= Standard_Standard
2937          loop
2938             exit when Is_Generic_Instance (S)
2939                  and then (In_Package_Body (S)
2940                             or else Ekind (S) = E_Procedure
2941                             or else Ekind (S) = E_Function);
2942
2943             if S = Curr_Unit
2944               or else (Ekind (Curr_Unit) = E_Package_Body
2945                         and then S = Spec_Entity (Curr_Unit))
2946               or else (Ekind (Curr_Unit) = E_Subprogram_Body
2947                         and then S =
2948                           Corresponding_Spec
2949                             (Unit_Declaration_Node (Curr_Unit)))
2950             then
2951                Removed := True;
2952
2953                --  Remove entities in current scopes from visibility, so
2954                --  than instance body is compiled in a clean environment.
2955
2956                Save_Scope_Stack (Handle_Use => False);
2957
2958                if Is_Child_Unit (S) then
2959
2960                   --  Remove child unit from stack, as well as inner scopes.
2961                   --  Removing the context of a child unit removes parent
2962                   --  units as well.
2963
2964                   while Current_Scope /= S loop
2965                      Num_Inner := Num_Inner + 1;
2966                      Inner_Scopes (Num_Inner) := Current_Scope;
2967                      Pop_Scope;
2968                   end loop;
2969
2970                   Pop_Scope;
2971                   Remove_Context (Curr_Comp);
2972                   Curr_Scope := S;
2973
2974                else
2975                   Remove_Context (Curr_Comp);
2976                end if;
2977
2978                if Ekind (Curr_Unit) = E_Package_Body then
2979                   Remove_Context (Library_Unit (Curr_Comp));
2980                end if;
2981             end if;
2982
2983             S := Scope (S);
2984          end loop;
2985
2986          New_Scope (Standard_Standard);
2987          Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
2988          Instantiate_Package_Body
2989            ((N, Act_Decl, Expander_Active, Current_Sem_Unit), True);
2990          Pop_Scope;
2991
2992          --  Restore context
2993
2994          Set_Is_Immediately_Visible (Gen_Comp, Vis);
2995
2996          --  Reset Generic_Instance flag so that use clauses can be installed
2997          --  in the proper order. (See Use_One_Package for effect of enclosing
2998          --  instances on processing of use clauses).
2999
3000          for J in 1 .. N_Instances loop
3001             Set_Is_Generic_Instance (Instances (J), False);
3002          end loop;
3003
3004          if Removed then
3005             Install_Context (Curr_Comp);
3006
3007             if Present (Curr_Scope)
3008               and then Is_Child_Unit (Curr_Scope)
3009             then
3010                New_Scope (Curr_Scope);
3011                Set_Is_Immediately_Visible (Curr_Scope);
3012
3013                --  Finally, restore inner scopes as well.
3014
3015                for J in reverse 1 .. Num_Inner loop
3016                   New_Scope (Inner_Scopes (J));
3017                end loop;
3018             end if;
3019
3020             Restore_Scope_Stack (Handle_Use => False);
3021          end if;
3022
3023          --  Restore use clauses. For a child unit, use clauses in the
3024          --  parents are restored when installing the context, so only
3025          --  those in inner scopes (and those local to the child unit itself)
3026          --  need to be installed explicitly.
3027
3028          if Is_Child_Unit (Curr_Unit)
3029            and then Removed
3030          then
3031             for J in reverse 1 .. Num_Inner + 1 loop
3032                Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
3033                  Use_Clauses (J);
3034                Install_Use_Clauses (Use_Clauses (J));
3035             end  loop;
3036
3037          else
3038             for J in reverse 1 .. Num_Scopes loop
3039                Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
3040                  Use_Clauses (J);
3041                Install_Use_Clauses (Use_Clauses (J));
3042             end  loop;
3043          end if;
3044
3045          for J in 1 .. N_Instances loop
3046             Set_Is_Generic_Instance (Instances (J), True);
3047          end loop;
3048
3049       --  If generic unit is in current unit, current context is correct.
3050
3051       else
3052          Instantiate_Package_Body
3053            ((N, Act_Decl, Expander_Active, Current_Sem_Unit), True);
3054       end if;
3055    end Inline_Instance_Body;
3056
3057    -------------------------------------
3058    -- Analyze_Procedure_Instantiation --
3059    -------------------------------------
3060
3061    procedure Analyze_Procedure_Instantiation (N : Node_Id) is
3062    begin
3063       Analyze_Subprogram_Instantiation (N, E_Procedure);
3064    end Analyze_Procedure_Instantiation;
3065
3066    --------------------------------------
3067    -- Analyze_Subprogram_Instantiation --
3068    --------------------------------------
3069
3070    procedure Analyze_Subprogram_Instantiation
3071      (N : Node_Id;
3072       K : Entity_Kind)
3073    is
3074       Loc    : constant Source_Ptr := Sloc (N);
3075       Gen_Id : constant Node_Id    := Name (N);
3076
3077       Anon_Id : constant Entity_Id :=
3078                   Make_Defining_Identifier (Sloc (Defining_Entity (N)),
3079                     Chars => New_External_Name
3080                                (Chars (Defining_Entity (N)), 'R'));
3081
3082       Act_Decl_Id : Entity_Id;
3083       Act_Decl    : Node_Id;
3084       Act_Spec    : Node_Id;
3085       Act_Tree    : Node_Id;
3086
3087       Gen_Unit         : Entity_Id;
3088       Gen_Decl         : Node_Id;
3089       Pack_Id          : Entity_Id;
3090       Parent_Installed : Boolean := False;
3091       Renaming_List    : List_Id;
3092
3093       procedure Analyze_Instance_And_Renamings;
3094       --  The instance must be analyzed in a context that includes the
3095       --  mappings of generic parameters into actuals. We create a package
3096       --  declaration for this purpose, and a subprogram with an internal
3097       --  name within the package. The subprogram instance is simply an
3098       --  alias for the internal subprogram, declared in the current scope.
3099
3100       ------------------------------------
3101       -- Analyze_Instance_And_Renamings --
3102       ------------------------------------
3103
3104       procedure Analyze_Instance_And_Renamings is
3105          Def_Ent   : constant Entity_Id := Defining_Entity (N);
3106          Pack_Decl : Node_Id;
3107
3108       begin
3109          if Nkind (Parent (N)) = N_Compilation_Unit then
3110
3111             --  For the case of a compilation unit, the container package
3112             --  has the same name as the instantiation, to insure that the
3113             --  binder calls the elaboration procedure with the right name.
3114             --  Copy the entity of the instance, which may have compilation
3115             --  level flags (e.g. Is_Child_Unit) set.
3116
3117             Pack_Id := New_Copy (Def_Ent);
3118
3119          else
3120             --  Otherwise we use the name of the instantiation concatenated
3121             --  with its source position to ensure uniqueness if there are
3122             --  several instantiations with the same name.
3123
3124             Pack_Id :=
3125               Make_Defining_Identifier (Loc,
3126                 Chars => New_External_Name
3127                            (Related_Id   => Chars (Def_Ent),
3128                             Suffix       => "GP",
3129                             Suffix_Index => Source_Offset (Sloc (Def_Ent))));
3130          end if;
3131
3132          Pack_Decl := Make_Package_Declaration (Loc,
3133            Specification => Make_Package_Specification (Loc,
3134              Defining_Unit_Name   => Pack_Id,
3135              Visible_Declarations => Renaming_List,
3136              End_Label            => Empty));
3137
3138          Set_Instance_Spec (N, Pack_Decl);
3139          Set_Is_Generic_Instance (Pack_Id);
3140          Set_Needs_Debug_Info (Pack_Id);
3141
3142          --  Case of not a compilation unit
3143
3144          if Nkind (Parent (N)) /= N_Compilation_Unit then
3145             Mark_Rewrite_Insertion (Pack_Decl);
3146             Insert_Before (N, Pack_Decl);
3147             Set_Has_Completion (Pack_Id);
3148
3149          --  Case of an instantiation that is a compilation unit
3150
3151          --  Place declaration on current node so context is complete
3152          --  for analysis (including nested instantiations), and for
3153          --  use in a context_clause (see Analyze_With_Clause).
3154
3155          else
3156             Set_Unit (Parent (N), Pack_Decl);
3157             Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
3158          end if;
3159
3160          Analyze (Pack_Decl);
3161          Check_Formal_Packages (Pack_Id);
3162          Set_Is_Generic_Instance (Pack_Id, False);
3163
3164          --  Body of the enclosing package is supplied when instantiating
3165          --  the subprogram body, after semantic  analysis is completed.
3166
3167          if Nkind (Parent (N)) = N_Compilation_Unit then
3168
3169             --  Remove package itself from visibility, so it does not
3170             --  conflict with subprogram.
3171
3172             Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
3173
3174             --  Set name and scope of internal subprogram so that the
3175             --  proper external name will be generated. The proper scope
3176             --  is the scope of the wrapper package. We need to generate
3177             --  debugging information for the internal subprogram, so set
3178             --  flag accordingly.
3179
3180             Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
3181             Set_Scope (Anon_Id, Scope (Pack_Id));
3182
3183             --  Mark wrapper package as referenced, to avoid spurious
3184             --  warnings if the instantiation appears in various with_
3185             --  clauses of subunits of the main unit.
3186
3187             Set_Referenced (Pack_Id);
3188          end if;
3189
3190          Set_Is_Generic_Instance (Anon_Id);
3191          Set_Needs_Debug_Info    (Anon_Id);
3192          Act_Decl_Id := New_Copy (Anon_Id);
3193
3194          Set_Parent            (Act_Decl_Id, Parent (Anon_Id));
3195          Set_Chars             (Act_Decl_Id, Chars (Defining_Entity (N)));
3196          Set_Sloc              (Act_Decl_Id, Sloc (Defining_Entity (N)));
3197          Set_Comes_From_Source (Act_Decl_Id, True);
3198
3199          --  The signature may involve types that are not frozen yet, but
3200          --  the subprogram will be frozen at the point the wrapper package
3201          --  is frozen, so it does not need its own freeze node. In fact, if
3202          --  one is created, it might conflict with the freezing actions from
3203          --  the wrapper package (see 7206-013).
3204
3205          Set_Has_Delayed_Freeze (Anon_Id, False);
3206
3207          --  If the instance is a child unit, mark the Id accordingly. Mark
3208          --  the anonymous entity as well, which is the real subprogram and
3209          --  which is used when the instance appears in a context clause.
3210
3211          Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
3212          Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
3213          New_Overloaded_Entity (Act_Decl_Id);
3214          Check_Eliminated  (Act_Decl_Id);
3215
3216          --  In compilation unit case, kill elaboration checks on the
3217          --  instantiation, since they are never needed -- the body is
3218          --  instantiated at the same point as the spec.
3219
3220          if Nkind (Parent (N)) = N_Compilation_Unit then
3221             Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
3222             Set_Kill_Elaboration_Checks       (Act_Decl_Id);
3223             Set_Is_Compilation_Unit (Anon_Id);
3224
3225             Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
3226          end if;
3227
3228          --  The instance is not a freezing point for the new subprogram.
3229
3230          Set_Is_Frozen (Act_Decl_Id, False);
3231
3232          if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
3233             Valid_Operator_Definition (Act_Decl_Id);
3234          end if;
3235
3236          Set_Alias  (Act_Decl_Id, Anon_Id);
3237          Set_Parent (Act_Decl_Id, Parent (Anon_Id));
3238          Set_Has_Completion (Act_Decl_Id);
3239          Set_Related_Instance (Pack_Id, Act_Decl_Id);
3240
3241          if Nkind (Parent (N)) = N_Compilation_Unit then
3242             Set_Body_Required (Parent (N), False);
3243          end if;
3244
3245       end Analyze_Instance_And_Renamings;
3246
3247    --  Start of processing for Analyze_Subprogram_Instantiation
3248
3249    begin
3250       --  Very first thing: apply the special kludge for Text_IO processing
3251       --  in case we are instantiating one of the children of [Wide_]Text_IO.
3252       --  Of course such an instantiation is bogus (these are packages, not
3253       --  subprograms), but we get a better error message if we do this.
3254
3255       Text_IO_Kludge (Gen_Id);
3256
3257       --  Make node global for error reporting.
3258
3259       Instantiation_Node := N;
3260       Pre_Analyze_Actuals (N);
3261
3262       Init_Env;
3263       Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
3264       Gen_Unit := Entity (Gen_Id);
3265
3266       Generate_Reference (Gen_Unit, Gen_Id);
3267
3268       if Nkind (Gen_Id) = N_Identifier
3269         and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
3270       then
3271          Error_Msg_NE
3272            ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
3273       end if;
3274
3275       if Etype (Gen_Unit) = Any_Type then
3276          Restore_Env;
3277          return;
3278       end if;
3279
3280       --  Verify that it is a generic subprogram of the right kind, and that
3281       --  it does not lead to a circular instantiation.
3282
3283       if Ekind (Gen_Unit) /= E_Generic_Procedure
3284         and then Ekind (Gen_Unit) /= E_Generic_Function
3285       then
3286          Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id);
3287
3288       elsif In_Open_Scopes (Gen_Unit) then
3289          Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
3290
3291       elsif K = E_Procedure
3292         and then Ekind (Gen_Unit) /= E_Generic_Procedure
3293       then
3294          if Ekind (Gen_Unit) = E_Generic_Function then
3295             Error_Msg_N
3296               ("cannot instantiate generic function as procedure", Gen_Id);
3297          else
3298             Error_Msg_N
3299               ("expect name of generic procedure in instantiation", Gen_Id);
3300          end if;
3301
3302       elsif K = E_Function
3303         and then Ekind (Gen_Unit) /= E_Generic_Function
3304       then
3305          if Ekind (Gen_Unit) = E_Generic_Procedure then
3306             Error_Msg_N
3307               ("cannot instantiate generic procedure as function", Gen_Id);
3308          else
3309             Error_Msg_N
3310               ("expect name of generic function in instantiation", Gen_Id);
3311          end if;
3312
3313       else
3314          Set_Entity (Gen_Id, Gen_Unit);
3315          Set_Is_Instantiated (Gen_Unit);
3316
3317          if In_Extended_Main_Source_Unit (N) then
3318             Generate_Reference (Gen_Unit, N);
3319          end if;
3320
3321          --  If renaming, get original unit
3322
3323          if Present (Renamed_Object (Gen_Unit))
3324            and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
3325                        or else
3326                      Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
3327          then
3328             Gen_Unit := Renamed_Object (Gen_Unit);
3329             Set_Is_Instantiated (Gen_Unit);
3330             Generate_Reference  (Gen_Unit, N);
3331          end if;
3332
3333          if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
3334             Error_Msg_Node_2 := Current_Scope;
3335             Error_Msg_NE
3336               ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
3337             Circularity_Detected := True;
3338             return;
3339          end if;
3340
3341          Gen_Decl := Unit_Declaration_Node (Gen_Unit);
3342
3343          --  The subprogram itself cannot contain a nested instance, so
3344          --  the current parent is left empty.
3345
3346          Set_Instance_Env (Gen_Unit, Empty);
3347
3348          --  Initialize renamings map, for error checking.
3349
3350          Generic_Renamings.Set_Last (0);
3351          Generic_Renamings_HTable.Reset;
3352
3353          Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
3354
3355          --  Copy original generic tree, to produce text for instantiation.
3356
3357          Act_Tree :=
3358            Copy_Generic_Node
3359              (Original_Node (Gen_Decl), Empty, Instantiating => True);
3360
3361          Act_Spec := Specification (Act_Tree);
3362          Renaming_List :=
3363            Analyze_Associations
3364              (N,
3365               Generic_Formal_Declarations (Act_Tree),
3366               Generic_Formal_Declarations (Gen_Decl));
3367
3368          --  Build the subprogram declaration, which does not appear
3369          --  in the generic template, and give it a sloc consistent
3370          --  with that of the template.
3371
3372          Set_Defining_Unit_Name (Act_Spec, Anon_Id);
3373          Set_Generic_Parent (Act_Spec, Gen_Unit);
3374          Act_Decl :=
3375            Make_Subprogram_Declaration (Sloc (Act_Spec),
3376              Specification => Act_Spec);
3377
3378          Set_Categorization_From_Pragmas (Act_Decl);
3379
3380          if Parent_Installed then
3381             Hide_Current_Scope;
3382          end if;
3383
3384          Append (Act_Decl, Renaming_List);
3385          Analyze_Instance_And_Renamings;
3386
3387          --  If the generic is marked Import (Intrinsic), then so is the
3388          --  instance. This indicates that there is no body to instantiate.
3389          --  If generic is marked inline, so it the instance, and the
3390          --  anonymous subprogram it renames. If inlined, or else if inlining
3391          --  is enabled for the compilation, we generate the instance body
3392          --  even if it is not within the main unit.
3393
3394          --  Any other  pragmas might also be inherited ???
3395
3396          if Is_Intrinsic_Subprogram (Gen_Unit) then
3397             Set_Is_Intrinsic_Subprogram (Anon_Id);
3398             Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
3399
3400             if Chars (Gen_Unit) = Name_Unchecked_Conversion then
3401                Validate_Unchecked_Conversion (N, Act_Decl_Id);
3402             end if;
3403          end if;
3404
3405          Generate_Definition (Act_Decl_Id);
3406
3407          Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
3408          Set_Is_Inlined (Anon_Id,     Is_Inlined (Gen_Unit));
3409
3410          if not Is_Intrinsic_Subprogram (Gen_Unit) then
3411             Check_Elab_Instantiation (N);
3412          end if;
3413
3414          Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
3415
3416          --  Subject to change, pending on if other pragmas are inherited ???
3417
3418          Validate_Categorization_Dependency (N, Act_Decl_Id);
3419
3420          if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
3421
3422             if not Generic_Separately_Compiled (Gen_Unit) then
3423                Inherit_Context (Gen_Decl, N);
3424             end if;
3425
3426             Restore_Private_Views (Pack_Id, False);
3427
3428             --  If the context requires a full instantiation, mark node for
3429             --  subsequent construction of the body.
3430
3431             if (Is_In_Main_Unit (N)
3432                   or else Is_Inlined (Act_Decl_Id))
3433               and then (Operating_Mode = Generate_Code
3434                           or else (Operating_Mode = Check_Semantics
3435                                     and then ASIS_Mode))
3436               and then (Expander_Active or else ASIS_Mode)
3437               and then not ABE_Is_Certain (N)
3438               and then not Is_Eliminated (Act_Decl_Id)
3439             then
3440                Pending_Instantiations.Increment_Last;
3441                Pending_Instantiations.Table (Pending_Instantiations.Last) :=
3442                  (N, Act_Decl, Expander_Active, Current_Sem_Unit);
3443                Check_Forward_Instantiation (Gen_Decl);
3444
3445                --  The wrapper package is always delayed, because it does
3446                --  not constitute a freeze point, but to insure that the
3447                --  freeze node is placed properly, it is created directly
3448                --  when instantiating the body (otherwise the freeze node
3449                --  might appear to early for nested instantiations).
3450
3451             elsif Nkind (Parent (N)) = N_Compilation_Unit then
3452
3453                --  For ASIS purposes, indicate that the wrapper package has
3454                --  replaced the instantiation node.
3455
3456                Rewrite (N, Unit (Parent (N)));
3457                Set_Unit (Parent (N), N);
3458             end if;
3459
3460          elsif Nkind (Parent (N)) = N_Compilation_Unit then
3461
3462                --  Replace instance node for library-level instantiations
3463                --  of intrinsic subprograms, for ASIS use.
3464
3465                Rewrite (N, Unit (Parent (N)));
3466                Set_Unit (Parent (N), N);
3467          end if;
3468
3469          if Parent_Installed then
3470             Remove_Parent;
3471          end if;
3472
3473          Restore_Env;
3474          Generic_Renamings.Set_Last (0);
3475          Generic_Renamings_HTable.Reset;
3476       end if;
3477
3478    exception
3479       when Instantiation_Error =>
3480          if Parent_Installed then
3481             Remove_Parent;
3482          end if;
3483    end Analyze_Subprogram_Instantiation;
3484
3485    -------------------------
3486    -- Get_Associated_Node --
3487    -------------------------
3488
3489    function Get_Associated_Node (N : Node_Id) return Node_Id is
3490       Assoc : Node_Id := Associated_Node (N);
3491
3492    begin
3493       if Nkind (Assoc) /= Nkind (N) then
3494          return Assoc;
3495
3496       elsif Nkind (Assoc) = N_Aggregate
3497         or else Nkind (Assoc) = N_Extension_Aggregate
3498       then
3499          return Assoc;
3500       else
3501          --  If the node is part of an inner generic, it may itself have been
3502          --  remapped into a further generic copy. Associated_Node is otherwise
3503          --  used for the entity of the node, and will be of a different node
3504          --  kind, or else N has been rewritten as a literal or function call.
3505
3506          while Present (Associated_Node (Assoc))
3507            and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc)
3508          loop
3509             Assoc := Associated_Node (Assoc);
3510          end loop;
3511
3512          --  Follow and additional link in case the final node was rewritten.
3513          --  This can only happen with nested generic units.
3514
3515          if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
3516            and then Present (Associated_Node (Assoc))
3517            and then (Nkind (Associated_Node (Assoc)) = N_Function_Call
3518                        or else
3519                      Nkind (Associated_Node (Assoc)) = N_Explicit_Dereference
3520                        or else
3521                      Nkind (Associated_Node (Assoc)) = N_Integer_Literal
3522                        or else
3523                      Nkind (Associated_Node (Assoc)) = N_Real_Literal
3524                        or else
3525                      Nkind (Associated_Node (Assoc)) = N_String_Literal)
3526          then
3527             Assoc := Associated_Node (Assoc);
3528          end if;
3529
3530          return Assoc;
3531       end if;
3532    end Get_Associated_Node;
3533
3534    -------------------------------------------
3535    -- Build_Instance_Compilation_Unit_Nodes --
3536    -------------------------------------------
3537
3538    procedure Build_Instance_Compilation_Unit_Nodes
3539      (N        : Node_Id;
3540       Act_Body : Node_Id;
3541       Act_Decl : Node_Id)
3542    is
3543       Decl_Cunit : Node_Id;
3544       Body_Cunit : Node_Id;
3545       Citem      : Node_Id;
3546       New_Main   : constant Entity_Id := Defining_Entity (Act_Decl);
3547       Old_Main   : constant Entity_Id := Cunit_Entity (Main_Unit);
3548
3549    begin
3550       --  A new compilation unit node is built for the instance declaration
3551
3552       Decl_Cunit :=
3553         Make_Compilation_Unit (Sloc (N),
3554           Context_Items  => Empty_List,
3555           Unit           => Act_Decl,
3556           Aux_Decls_Node =>
3557             Make_Compilation_Unit_Aux (Sloc (N)));
3558
3559       Set_Parent_Spec   (Act_Decl, Parent_Spec (N));
3560       Set_Body_Required (Decl_Cunit, True);
3561
3562       --  We use the original instantiation compilation unit as the resulting
3563       --  compilation unit of the instance, since this is the main unit.
3564
3565       Rewrite (N, Act_Body);
3566       Body_Cunit := Parent (N);
3567
3568       --  The two compilation unit nodes are linked by the Library_Unit field
3569
3570       Set_Library_Unit  (Decl_Cunit, Body_Cunit);
3571       Set_Library_Unit  (Body_Cunit, Decl_Cunit);
3572
3573       --  Preserve the private nature of the package if needed.
3574
3575       Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
3576
3577       --  If the instance is not the main unit, its context, categorization,
3578       --  and elaboration entity are not relevant to the compilation.
3579
3580       if Parent (N) /= Cunit (Main_Unit) then
3581          return;
3582       end if;
3583
3584       --  The context clause items on the instantiation, which are now
3585       --  attached to the body compilation unit (since the body overwrote
3586       --  the original instantiation node), semantically belong on the spec,
3587       --  so copy them there. It's harmless to leave them on the body as well.
3588       --  In fact one could argue that they belong in both places.
3589
3590       Citem := First (Context_Items (Body_Cunit));
3591       while Present (Citem) loop
3592          Append (New_Copy (Citem), Context_Items (Decl_Cunit));
3593          Next (Citem);
3594       end loop;
3595
3596       --  Propagate categorization flags on packages, so that they appear
3597       --  in ali file for the spec of the unit.
3598
3599       if Ekind (New_Main) = E_Package then
3600          Set_Is_Pure           (Old_Main, Is_Pure (New_Main));
3601          Set_Is_Preelaborated  (Old_Main, Is_Preelaborated (New_Main));
3602          Set_Is_Remote_Types   (Old_Main, Is_Remote_Types (New_Main));
3603          Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main));
3604          Set_Is_Remote_Call_Interface
3605            (Old_Main, Is_Remote_Call_Interface (New_Main));
3606       end if;
3607
3608       --  Make entry in Units table, so that binder can generate call to
3609       --  elaboration procedure for body, if any.
3610
3611       Make_Instance_Unit (Body_Cunit);
3612       Main_Unit_Entity := New_Main;
3613       Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
3614
3615       --  Build elaboration entity, since the instance may certainly
3616       --  generate elaboration code requiring a flag for protection.
3617
3618       Build_Elaboration_Entity (Decl_Cunit, New_Main);
3619    end Build_Instance_Compilation_Unit_Nodes;
3620
3621    -----------------------------------
3622    -- Check_Formal_Package_Instance --
3623    -----------------------------------
3624
3625    --  If the formal has specific parameters, they must match those of the
3626    --  actual. Both of them are instances, and the renaming declarations
3627    --  for their formal parameters appear in the same order in both. The
3628    --  analyzed formal has been analyzed in the context of the current
3629    --  instance.
3630
3631    procedure Check_Formal_Package_Instance
3632      (Formal_Pack : Entity_Id;
3633       Actual_Pack : Entity_Id)
3634    is
3635       E1 : Entity_Id := First_Entity (Actual_Pack);
3636       E2 : Entity_Id := First_Entity (Formal_Pack);
3637
3638       Expr1 : Node_Id;
3639       Expr2 : Node_Id;
3640
3641       procedure Check_Mismatch (B : Boolean);
3642       --  Common error routine for mismatch between the parameters of
3643       --  the actual instance and those of the formal package.
3644
3645       function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean;
3646       --  The formal may come from a nested formal package, and the actual
3647       --  may have been constant-folded. To determine whether the two denote
3648       --  the same entity we may have to traverse several definitions to
3649       --  recover the ultimate entity that they refer to.
3650
3651       function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
3652       --  Similarly, if the formal comes from a nested formal package, the
3653       --  actual may designate the formal through multiple renamings, which
3654       --  have to be followed to determine the original variable in question.
3655
3656       --------------------
3657       -- Check_Mismatch --
3658       --------------------
3659
3660       procedure Check_Mismatch (B : Boolean) is
3661       begin
3662          if B then
3663             Error_Msg_NE
3664               ("actual for & in actual instance does not match formal",
3665                Parent (Actual_Pack), E1);
3666          end if;
3667       end Check_Mismatch;
3668
3669       --------------------------------
3670       -- Same_Instantiated_Constant --
3671       --------------------------------
3672
3673       function Same_Instantiated_Constant
3674         (E1, E2 : Entity_Id) return Boolean
3675       is
3676          Ent : Entity_Id;
3677       begin
3678          Ent := E2;
3679          while Present (Ent) loop
3680             if E1 = Ent then
3681                return True;
3682
3683             elsif Ekind (Ent) /= E_Constant then
3684                return False;
3685
3686             elsif Is_Entity_Name (Constant_Value (Ent)) then
3687                if  Entity (Constant_Value (Ent)) = E1 then
3688                   return True;
3689                else
3690                   Ent := Entity (Constant_Value (Ent));
3691                end if;
3692
3693             --  The actual may be a constant that has been folded. Recover
3694             --  original name.
3695
3696             elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
3697                   Ent := Entity (Original_Node (Constant_Value (Ent)));
3698             else
3699                return False;
3700             end if;
3701          end loop;
3702
3703          return False;
3704       end Same_Instantiated_Constant;
3705
3706       --------------------------------
3707       -- Same_Instantiated_Variable --
3708       --------------------------------
3709
3710       function Same_Instantiated_Variable
3711         (E1, E2 : Entity_Id) return Boolean
3712       is
3713          function Original_Entity (E : Entity_Id) return Entity_Id;
3714          --  Follow chain of renamings to the ultimate ancestor.
3715
3716          ---------------------
3717          -- Original_Entity --
3718          ---------------------
3719
3720          function Original_Entity (E : Entity_Id) return Entity_Id is
3721             Orig : Entity_Id;
3722
3723          begin
3724             Orig := E;
3725             while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration
3726               and then Present (Renamed_Object (Orig))
3727               and then Is_Entity_Name (Renamed_Object (Orig))
3728             loop
3729                Orig := Entity (Renamed_Object (Orig));
3730             end loop;
3731
3732             return Orig;
3733          end Original_Entity;
3734
3735       --  Start of processing for Same_Instantiated_Variable
3736
3737       begin
3738          return Ekind (E1) = Ekind (E2)
3739            and then Original_Entity (E1) = Original_Entity (E2);
3740       end Same_Instantiated_Variable;
3741
3742    --  Start of processing for Check_Formal_Package_Instance
3743
3744    begin
3745       while Present (E1)
3746         and then Present (E2)
3747       loop
3748          exit when Ekind (E1) = E_Package
3749            and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
3750
3751          if Is_Type (E1) then
3752
3753             --  Subtypes must statically match. E1 and E2 are the
3754             --  local entities that are subtypes of the actuals.
3755             --  Itypes generated for other parameters need not be checked,
3756             --  the check will be performed on the parameters themselves.
3757
3758             if not Is_Itype (E1)
3759               and then not Is_Itype (E2)
3760             then
3761                Check_Mismatch
3762                  (not Is_Type (E2)
3763                    or else Etype (E1) /= Etype (E2)
3764                    or else not Subtypes_Statically_Match (E1, E2));
3765             end if;
3766
3767          elsif Ekind (E1) = E_Constant then
3768
3769             --  IN parameters must denote the same static value, or
3770             --  the same constant, or the literal null.
3771
3772             Expr1 := Expression (Parent (E1));
3773
3774             if Ekind (E2) /= E_Constant then
3775                Check_Mismatch (True);
3776                goto Next_E;
3777             else
3778                Expr2 := Expression (Parent (E2));
3779             end if;
3780
3781             if Is_Static_Expression (Expr1) then
3782
3783                if not Is_Static_Expression (Expr2) then
3784                   Check_Mismatch (True);
3785
3786                elsif Is_Integer_Type (Etype (E1)) then
3787
3788                   declare
3789                      V1 : constant Uint := Expr_Value (Expr1);
3790                      V2 : constant Uint := Expr_Value (Expr2);
3791                   begin
3792                      Check_Mismatch (V1 /= V2);
3793                   end;
3794
3795                elsif Is_Real_Type (Etype (E1)) then
3796                   declare
3797                      V1 : constant Ureal := Expr_Value_R (Expr1);
3798                      V2 : constant Ureal := Expr_Value_R (Expr2);
3799                   begin
3800                      Check_Mismatch (V1 /= V2);
3801                   end;
3802
3803                elsif Is_String_Type (Etype (E1))
3804                  and then Nkind (Expr1) = N_String_Literal
3805                then
3806
3807                   if Nkind (Expr2) /= N_String_Literal then
3808                      Check_Mismatch (True);
3809                   else
3810                      Check_Mismatch
3811                        (not String_Equal (Strval (Expr1), Strval (Expr2)));
3812                   end if;
3813                end if;
3814
3815             elsif Is_Entity_Name (Expr1) then
3816                if Is_Entity_Name (Expr2) then
3817                   if Entity (Expr1) = Entity (Expr2) then
3818                      null;
3819                   else
3820                      Check_Mismatch
3821                        (not Same_Instantiated_Constant
3822                          (Entity (Expr1), Entity (Expr2)));
3823                   end if;
3824                else
3825                   Check_Mismatch (True);
3826                end if;
3827
3828             elsif Is_Entity_Name (Original_Node (Expr1))
3829               and then Is_Entity_Name (Expr2)
3830             and then
3831               Same_Instantiated_Constant
3832                 (Entity (Original_Node (Expr1)), Entity (Expr2))
3833             then
3834                null;
3835
3836             elsif Nkind (Expr1) = N_Null then
3837                Check_Mismatch (Nkind (Expr1) /= N_Null);
3838
3839             else
3840                Check_Mismatch (True);
3841             end if;
3842
3843          elsif Ekind (E1) = E_Variable then
3844             Check_Mismatch (not Same_Instantiated_Variable (E1, E2));
3845
3846          elsif Ekind (E1) = E_Package then
3847             Check_Mismatch
3848               (Ekind (E1) /= Ekind (E2)
3849                 or else Renamed_Object (E1) /= Renamed_Object (E2));
3850
3851          elsif Is_Overloadable (E1) then
3852
3853             --  Verify that the names of the  entities match.
3854             --  What if actual is an attribute ???
3855
3856             Check_Mismatch
3857               (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
3858
3859          else
3860             raise Program_Error;
3861          end if;
3862
3863          <<Next_E>>
3864             Next_Entity (E1);
3865             Next_Entity (E2);
3866       end loop;
3867    end Check_Formal_Package_Instance;
3868
3869    ---------------------------
3870    -- Check_Formal_Packages --
3871    ---------------------------
3872
3873    procedure Check_Formal_Packages (P_Id : Entity_Id) is
3874       E        : Entity_Id;
3875       Formal_P : Entity_Id;
3876
3877    begin
3878       --  Iterate through the declarations in the instance, looking for
3879       --  package renaming declarations that denote instances of formal
3880       --  packages. Stop when we find the renaming of the current package
3881       --  itself. The declaration for a formal package without a box is
3882       --  followed by an internal entity that repeats the instantiation.
3883
3884       E := First_Entity (P_Id);
3885       while Present (E) loop
3886          if Ekind (E) = E_Package then
3887             if Renamed_Object (E) = P_Id then
3888                exit;
3889
3890             elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
3891                null;
3892
3893             elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
3894                Formal_P := Next_Entity (E);
3895                Check_Formal_Package_Instance (Formal_P, E);
3896             end if;
3897          end if;
3898
3899          Next_Entity (E);
3900       end loop;
3901    end Check_Formal_Packages;
3902
3903    ---------------------------------
3904    -- Check_Forward_Instantiation --
3905    ---------------------------------
3906
3907    procedure Check_Forward_Instantiation (Decl : Node_Id) is
3908       S        : Entity_Id;
3909       Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
3910
3911    begin
3912       --  The instantiation appears before the generic body if we are in the
3913       --  scope of the unit containing the generic, either in its spec or in
3914       --  the package body. and before the generic body.
3915
3916       if Ekind (Gen_Comp) = E_Package_Body then
3917          Gen_Comp := Spec_Entity (Gen_Comp);
3918       end if;
3919
3920       if In_Open_Scopes (Gen_Comp)
3921         and then No (Corresponding_Body (Decl))
3922       then
3923          S := Current_Scope;
3924
3925          while Present (S)
3926            and then not Is_Compilation_Unit (S)
3927            and then not Is_Child_Unit (S)
3928          loop
3929             if Ekind (S) = E_Package then
3930                Set_Has_Forward_Instantiation (S);
3931             end if;
3932
3933             S := Scope (S);
3934          end loop;
3935       end if;
3936    end Check_Forward_Instantiation;
3937
3938    ---------------------------
3939    -- Check_Generic_Actuals --
3940    ---------------------------
3941
3942    --  The visibility of the actuals may be different between the
3943    --  point of generic instantiation and the instantiation of the body.
3944
3945    procedure Check_Generic_Actuals
3946      (Instance      : Entity_Id;
3947       Is_Formal_Box : Boolean)
3948    is
3949       E      : Entity_Id;
3950       Astype : Entity_Id;
3951
3952    begin
3953       E := First_Entity (Instance);
3954       while Present (E) loop
3955          if Is_Type (E)
3956            and then Nkind (Parent (E)) = N_Subtype_Declaration
3957            and then Scope (Etype (E)) /= Instance
3958            and then Is_Entity_Name (Subtype_Indication (Parent (E)))
3959          then
3960             Check_Private_View (Subtype_Indication (Parent (E)));
3961             Set_Is_Generic_Actual_Type (E, True);
3962             Set_Is_Hidden (E, False);
3963
3964             --  We constructed the generic actual type as a subtype of
3965             --  the supplied type. This means that it normally would not
3966             --  inherit subtype specific attributes of the actual, which
3967             --  is wrong for the generic case.
3968
3969             Astype := Ancestor_Subtype (E);
3970
3971             if No (Astype) then
3972
3973                --  can happen when E is an itype that is the full view of
3974                --  a private type completed, e.g. with a constrained array.
3975
3976                Astype := Base_Type (E);
3977             end if;
3978
3979             Set_Size_Info      (E,                (Astype));
3980             Set_RM_Size        (E, RM_Size        (Astype));
3981             Set_First_Rep_Item (E, First_Rep_Item (Astype));
3982
3983             if Is_Discrete_Or_Fixed_Point_Type (E) then
3984                Set_RM_Size (E, RM_Size (Astype));
3985
3986             --  In  nested instances, the base type of an access actual
3987             --  may itself be private, and need to be exchanged.
3988
3989             elsif Is_Access_Type (E)
3990               and then Is_Private_Type (Etype (E))
3991             then
3992                Check_Private_View
3993                  (New_Occurrence_Of (Etype (E), Sloc (Instance)));
3994             end if;
3995
3996          elsif Ekind (E) = E_Package then
3997
3998             --  If this is the renaming for the current instance, we're done.
3999             --  Otherwise it is a formal package. If the corresponding formal
4000             --  was declared with a box, the (instantiations of the) generic
4001             --  formal part are also visible. Otherwise, ignore the entity
4002             --  created to validate the actuals.
4003
4004             if Renamed_Object (E) = Instance then
4005                exit;
4006
4007             elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
4008                null;
4009
4010             --  The visibility of a formal of an enclosing generic is already
4011             --  correct.
4012
4013             elsif Denotes_Formal_Package (E) then
4014                null;
4015
4016             elsif Present (Associated_Formal_Package (E))
4017               and then Box_Present (Parent (Associated_Formal_Package (E)))
4018             then
4019                Check_Generic_Actuals (Renamed_Object (E), True);
4020                Set_Is_Hidden (E, False);
4021             end if;
4022
4023          --  If this is a subprogram instance (in a wrapper package) the
4024          --  actual is fully visible.
4025
4026          elsif Is_Wrapper_Package (Instance) then
4027             Set_Is_Hidden (E, False);
4028
4029          else
4030             Set_Is_Hidden (E, not Is_Formal_Box);
4031          end if;
4032
4033          Next_Entity (E);
4034       end loop;
4035    end Check_Generic_Actuals;
4036
4037    ------------------------------
4038    -- Check_Generic_Child_Unit --
4039    ------------------------------
4040
4041    procedure Check_Generic_Child_Unit
4042      (Gen_Id           : Node_Id;
4043       Parent_Installed : in out Boolean)
4044    is
4045       Loc      : constant Source_Ptr := Sloc (Gen_Id);
4046       Gen_Par  : Entity_Id := Empty;
4047       Inst_Par : Entity_Id;
4048       E        : Entity_Id;
4049       S        : Node_Id;
4050
4051       function Find_Generic_Child
4052         (Scop : Entity_Id;
4053          Id   : Node_Id)
4054          return Entity_Id;
4055       --  Search generic parent for possible child unit with the given name.
4056
4057       function In_Enclosing_Instance return Boolean;
4058       --  Within an instance of the parent, the child unit may be denoted
4059       --  by a simple name, or an abbreviated expanded name. Examine enclosing
4060       --  scopes to locate a possible parent instantiation.
4061
4062       ------------------------
4063       -- Find_Generic_Child --
4064       ------------------------
4065
4066       function Find_Generic_Child
4067         (Scop : Entity_Id;
4068          Id   : Node_Id)
4069          return Entity_Id
4070       is
4071          E : Entity_Id;
4072
4073       begin
4074          --  If entity of name is already set, instance has already been
4075          --  resolved, e.g. in an enclosing instantiation.
4076
4077          if Present (Entity (Id)) then
4078             if Scope (Entity (Id)) = Scop then
4079                return Entity (Id);
4080             else
4081                return Empty;
4082             end if;
4083
4084          else
4085             E := First_Entity (Scop);
4086             while Present (E) loop
4087                if Chars (E) = Chars (Id)
4088                  and then Is_Child_Unit (E)
4089                then
4090                   if Is_Child_Unit (E)
4091                     and then not Is_Visible_Child_Unit (E)
4092                   then
4093                      Error_Msg_NE
4094                        ("generic child unit& is not visible", Gen_Id, E);
4095                   end if;
4096
4097                   Set_Entity (Id, E);
4098                   return E;
4099                end if;
4100
4101                Next_Entity (E);
4102             end loop;
4103
4104             return Empty;
4105          end if;
4106       end Find_Generic_Child;
4107
4108       ---------------------------
4109       -- In_Enclosing_Instance --
4110       ---------------------------
4111
4112       function In_Enclosing_Instance return Boolean is
4113          Enclosing_Instance : Node_Id;
4114          Instance_Decl      : Node_Id;
4115
4116       begin
4117          Enclosing_Instance := Current_Scope;
4118
4119          while Present (Enclosing_Instance) loop
4120             Instance_Decl := Unit_Declaration_Node (Enclosing_Instance);
4121
4122             if Ekind (Enclosing_Instance) = E_Package
4123               and then Is_Generic_Instance (Enclosing_Instance)
4124               and then Present
4125                 (Generic_Parent (Specification (Instance_Decl)))
4126             then
4127                --  Check whether the generic we are looking for is a child
4128                --  of this instance.
4129
4130                E := Find_Generic_Child
4131                       (Generic_Parent (Specification (Instance_Decl)), Gen_Id);
4132                exit when Present (E);
4133
4134             else
4135                E := Empty;
4136             end if;
4137
4138             Enclosing_Instance := Scope (Enclosing_Instance);
4139          end loop;
4140
4141          if No (E) then
4142
4143             --  Not a child unit
4144
4145             Analyze (Gen_Id);
4146             return False;
4147
4148          else
4149             Rewrite (Gen_Id,
4150               Make_Expanded_Name (Loc,
4151                 Chars         => Chars (E),
4152                 Prefix        => New_Occurrence_Of (Enclosing_Instance, Loc),
4153                 Selector_Name => New_Occurrence_Of (E, Loc)));
4154
4155             Set_Entity (Gen_Id, E);
4156             Set_Etype  (Gen_Id, Etype (E));
4157             Parent_Installed := False;      -- Already in scope.
4158             return True;
4159          end if;
4160       end In_Enclosing_Instance;
4161
4162    --  Start of processing for Check_Generic_Child_Unit
4163
4164    begin
4165       --  If the name of the generic is given by a selected component, it
4166       --  may be the name of a generic child unit, and the prefix is the name
4167       --  of an instance of the parent, in which case the child unit must be
4168       --  visible. If this instance is not in scope, it must be placed there
4169       --  and removed after instantiation, because what is being instantiated
4170       --  is not the original child, but the corresponding child present in
4171       --  the instance of the parent.
4172
4173       --  If the child is instantiated within the parent, it can be given by
4174       --  a simple name. In this case the instance is already in scope, but
4175       --  the child generic must be recovered from the generic parent as well.
4176
4177       if Nkind (Gen_Id) = N_Selected_Component then
4178          S := Selector_Name (Gen_Id);
4179          Analyze (Prefix (Gen_Id));
4180          Inst_Par := Entity (Prefix (Gen_Id));
4181
4182          if Ekind (Inst_Par) = E_Package
4183            and then Present (Renamed_Object (Inst_Par))
4184          then
4185             Inst_Par := Renamed_Object (Inst_Par);
4186          end if;
4187
4188          if Ekind (Inst_Par) = E_Package then
4189             if Nkind (Parent (Inst_Par)) = N_Package_Specification then
4190                Gen_Par := Generic_Parent (Parent (Inst_Par));
4191
4192             elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name
4193               and then
4194                 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification
4195             then
4196                Gen_Par := Generic_Parent (Parent (Parent (Inst_Par)));
4197             end if;
4198
4199          elsif Ekind (Inst_Par) = E_Generic_Package
4200            and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
4201          then
4202             --  A formal package may be a real child package, and not the
4203             --  implicit instance within a parent. In this case the child is
4204             --  not visible and has to be retrieved explicitly as well.
4205
4206             Gen_Par := Inst_Par;
4207          end if;
4208
4209          if Present (Gen_Par) then
4210
4211             --  The prefix denotes an instantiation. The entity itself
4212             --  may be a nested generic, or a child unit.
4213
4214             E := Find_Generic_Child (Gen_Par, S);
4215
4216             if Present (E) then
4217                Change_Selected_Component_To_Expanded_Name (Gen_Id);
4218                Set_Entity (Gen_Id, E);
4219                Set_Etype (Gen_Id, Etype (E));
4220                Set_Entity (S, E);
4221                Set_Etype (S, Etype (E));
4222
4223                --  Indicate that this is a reference to the parent.
4224
4225                if In_Extended_Main_Source_Unit (Gen_Id) then
4226                   Set_Is_Instantiated (Inst_Par);
4227                end if;
4228
4229                --  A common mistake is to replicate the naming scheme of
4230                --  a hierarchy by instantiating a generic child directly,
4231                --  rather than the implicit child in a parent instance:
4232
4233                --  generic .. package Gpar is ..
4234                --  generic .. package Gpar.Child is ..
4235                --  package Par is new Gpar ();
4236
4237                --  with Gpar.Child;
4238                --  package Par.Child is new Gpar.Child ();
4239                --                           rather than Par.Child
4240
4241                --  In this case the instantiation is within Par, which is
4242                --  an instance, but Gpar does not denote Par because we are
4243                --  not IN the instance of Gpar, so this is illegal. The test
4244                --  below recognizes this particular case.
4245
4246                if Is_Child_Unit (E)
4247                  and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
4248                  and then (not In_Instance
4249                              or else Nkind (Parent (Parent (Gen_Id))) =
4250                                                          N_Compilation_Unit)
4251                then
4252                   Error_Msg_N
4253                     ("prefix of generic child unit must be instance of parent",
4254                       Gen_Id);
4255                end if;
4256
4257                if not In_Open_Scopes (Inst_Par)
4258                  and then Nkind (Parent (Gen_Id)) not in
4259                                            N_Generic_Renaming_Declaration
4260                then
4261                   Install_Parent (Inst_Par);
4262                   Parent_Installed := True;
4263                end if;
4264
4265             else
4266                --  If the generic parent does not contain an entity that
4267                --  corresponds to the selector, the instance doesn't either.
4268                --  Analyzing the node will yield the appropriate error message.
4269                --  If the entity is not a child unit, then it is an inner
4270                --  generic in the parent.
4271
4272                Analyze (Gen_Id);
4273             end if;
4274
4275          else
4276             Analyze (Gen_Id);
4277
4278             if Is_Child_Unit (Entity (Gen_Id))
4279               and then
4280                 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
4281               and then not In_Open_Scopes (Inst_Par)
4282             then
4283                Install_Parent (Inst_Par);
4284                Parent_Installed := True;
4285             end if;
4286          end if;
4287
4288       elsif Nkind (Gen_Id) = N_Expanded_Name then
4289
4290          --  Entity already present, analyze prefix, whose meaning may be
4291          --  an instance in the current context. If it is an instance of
4292          --  a relative within another, the proper parent may still have
4293          --  to be installed, if they are not of the same generation.
4294
4295          Analyze (Prefix (Gen_Id));
4296          Inst_Par := Entity (Prefix (Gen_Id));
4297
4298          if In_Enclosing_Instance then
4299             null;
4300
4301          elsif Present (Entity (Gen_Id))
4302            and then Is_Child_Unit (Entity (Gen_Id))
4303            and then not In_Open_Scopes (Inst_Par)
4304          then
4305             Install_Parent (Inst_Par);
4306             Parent_Installed := True;
4307          end if;
4308
4309       elsif In_Enclosing_Instance then
4310
4311          --  The child unit is found in some enclosing scope
4312
4313          null;
4314
4315       else
4316          Analyze (Gen_Id);
4317
4318          --  If this is the renaming of the implicit child in a parent
4319          --  instance, recover the parent name and install it.
4320
4321          if Is_Entity_Name (Gen_Id) then
4322             E := Entity (Gen_Id);
4323
4324             if Is_Generic_Unit (E)
4325               and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration
4326               and then Is_Child_Unit (Renamed_Object (E))
4327               and then Is_Generic_Unit (Scope (Renamed_Object (E)))
4328               and then Nkind (Name (Parent (E))) = N_Expanded_Name
4329             then
4330                Rewrite (Gen_Id,
4331                  New_Copy_Tree (Name (Parent (E))));
4332                Inst_Par := Entity (Prefix (Gen_Id));
4333
4334                if not In_Open_Scopes (Inst_Par) then
4335                   Install_Parent (Inst_Par);
4336                   Parent_Installed := True;
4337                end if;
4338
4339             --  If it is a child unit of a non-generic parent, it may be
4340             --  use-visible and given by a direct name. Install parent as
4341             --  for other cases.
4342
4343             elsif Is_Generic_Unit (E)
4344               and then Is_Child_Unit (E)
4345               and then
4346                 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
4347               and then not Is_Generic_Unit (Scope (E))
4348             then
4349                if not In_Open_Scopes (Scope (E)) then
4350                   Install_Parent (Scope (E));
4351                   Parent_Installed := True;
4352                end if;
4353             end if;
4354          end if;
4355       end if;
4356    end Check_Generic_Child_Unit;
4357
4358    -----------------------------
4359    -- Check_Hidden_Child_Unit --
4360    -----------------------------
4361
4362    procedure Check_Hidden_Child_Unit
4363      (N           : Node_Id;
4364       Gen_Unit    : Entity_Id;
4365       Act_Decl_Id : Entity_Id)
4366    is
4367       Gen_Id : constant Node_Id := Name (N);
4368
4369    begin
4370       if Is_Child_Unit (Gen_Unit)
4371         and then Is_Child_Unit (Act_Decl_Id)
4372         and then Nkind (Gen_Id) = N_Expanded_Name
4373         and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id)
4374         and then Chars (Gen_Unit) = Chars (Act_Decl_Id)
4375       then
4376          Error_Msg_Node_2 := Scope (Act_Decl_Id);
4377          Error_Msg_NE
4378            ("generic unit & is implicitly declared in &",
4379              Defining_Unit_Name (N), Gen_Unit);
4380          Error_Msg_N ("\instance must have different name",
4381            Defining_Unit_Name (N));
4382       end if;
4383    end Check_Hidden_Child_Unit;
4384
4385    ------------------------
4386    -- Check_Private_View --
4387    ------------------------
4388
4389    procedure Check_Private_View (N : Node_Id) is
4390       T : constant Entity_Id := Etype (N);
4391       BT : Entity_Id;
4392
4393    begin
4394       --  Exchange views if the type was not private in the generic but is
4395       --  private at the point of instantiation. Do not exchange views if
4396       --  the scope of the type is in scope. This can happen if both generic
4397       --  and instance are sibling units, or if type is defined in a parent.
4398       --  In this case the visibility of the type will be correct for all
4399       --  semantic checks.
4400
4401       if Present (T) then
4402          BT := Base_Type (T);
4403
4404          if Is_Private_Type (T)
4405            and then not Has_Private_View (N)
4406            and then Present (Full_View (T))
4407            and then not In_Open_Scopes (Scope (T))
4408          then
4409             --  In the generic, the full type was visible. Save the
4410             --  private entity, for subsequent exchange.
4411
4412             Switch_View (T);
4413
4414          elsif Has_Private_View (N)
4415            and then not Is_Private_Type (T)
4416            and then not Has_Been_Exchanged (T)
4417            and then Etype (Get_Associated_Node (N)) /= T
4418          then
4419             --  Only the private declaration was visible in the generic. If
4420             --  the type appears in a subtype declaration, the subtype in the
4421             --  instance must have a view compatible with that of its parent,
4422             --  which must be exchanged (see corresponding code in Restore_
4423             --  Private_Views). Otherwise, if the type is defined in a parent
4424             --  unit, leave full visibility within instance, which is safe.
4425
4426             if In_Open_Scopes (Scope (Base_Type (T)))
4427               and then not Is_Private_Type (Base_Type (T))
4428               and then Comes_From_Source (Base_Type (T))
4429             then
4430                null;
4431
4432             elsif Nkind (Parent (N)) = N_Subtype_Declaration
4433               or else not In_Private_Part (Scope (Base_Type (T)))
4434             then
4435                Append_Elmt (T, Exchanged_Views);
4436                Exchange_Declarations (Etype (Get_Associated_Node (N)));
4437             end if;
4438
4439          --  For composite types with inconsistent representation
4440          --  exchange component types accordingly.
4441
4442          elsif Is_Access_Type (T)
4443            and then Is_Private_Type (Designated_Type (T))
4444            and then not Has_Private_View (N)
4445            and then Present (Full_View (Designated_Type (T)))
4446          then
4447             Switch_View (Designated_Type (T));
4448
4449          elsif Is_Array_Type (T)
4450            and then Is_Private_Type (Component_Type (T))
4451            and then not Has_Private_View (N)
4452            and then Present (Full_View (Component_Type (T)))
4453          then
4454             Switch_View (Component_Type (T));
4455
4456          elsif Is_Private_Type (T)
4457            and then Present (Full_View (T))
4458            and then Is_Array_Type (Full_View (T))
4459            and then Is_Private_Type (Component_Type (Full_View (T)))
4460          then
4461             Switch_View (T);
4462
4463          --  Finally, a non-private subtype may have a private base type,
4464          --  which must be exchanged for consistency. This can happen when
4465          --  instantiating a package body, when the scope stack is empty
4466          --  but in fact the subtype and the base type are declared in an
4467          --  enclosing scope.
4468
4469          elsif not Is_Private_Type (T)
4470            and then not Has_Private_View (N)
4471            and then Is_Private_Type (Base_Type (T))
4472            and then Present (Full_View (BT))
4473            and then not Is_Generic_Type (BT)
4474            and then not In_Open_Scopes (BT)
4475          then
4476             Append_Elmt (Full_View (BT), Exchanged_Views);
4477             Exchange_Declarations (BT);
4478          end if;
4479       end if;
4480    end Check_Private_View;
4481
4482    --------------------------
4483    -- Contains_Instance_Of --
4484    --------------------------
4485
4486    function Contains_Instance_Of
4487      (Inner : Entity_Id;
4488       Outer : Entity_Id;
4489       N     : Node_Id)
4490       return  Boolean
4491    is
4492       Elmt : Elmt_Id;
4493       Scop : Entity_Id;
4494
4495    begin
4496       Scop := Outer;
4497
4498       --  Verify that there are no circular instantiations. We check whether
4499       --  the unit contains an instance of the current scope or some enclosing
4500       --  scope (in case one of the instances appears in a subunit). Longer
4501       --  circularities involving subunits might seem too pathological to
4502       --  consider, but they were not too pathological for the authors of
4503       --  DEC bc30vsq, so we loop over all enclosing scopes, and mark all
4504       --  enclosing generic scopes as containing an instance.
4505
4506       loop
4507          --  Within a generic subprogram body, the scope is not generic, to
4508          --  allow for recursive subprograms. Use the declaration to determine
4509          --  whether this is a generic unit.
4510
4511          if Ekind (Scop) = E_Generic_Package
4512            or else (Is_Subprogram (Scop)
4513                       and then Nkind (Unit_Declaration_Node (Scop)) =
4514                                         N_Generic_Subprogram_Declaration)
4515          then
4516             Elmt := First_Elmt (Inner_Instances (Inner));
4517
4518             while Present (Elmt) loop
4519                if Node (Elmt) = Scop then
4520                   Error_Msg_Node_2 := Inner;
4521                   Error_Msg_NE
4522                     ("circular Instantiation: & instantiated within &!",
4523                        N, Scop);
4524                   return True;
4525
4526                elsif Node (Elmt) = Inner then
4527                   return True;
4528
4529                elsif Contains_Instance_Of (Node (Elmt), Scop, N) then
4530                   Error_Msg_Node_2 := Inner;
4531                   Error_Msg_NE
4532                     ("circular Instantiation: & instantiated within &!",
4533                       N, Node (Elmt));
4534                   return True;
4535                end if;
4536
4537                Next_Elmt (Elmt);
4538             end loop;
4539
4540             --  Indicate that Inner is being instantiated within  Scop.
4541
4542             Append_Elmt (Inner, Inner_Instances (Scop));
4543          end if;
4544
4545          if Scop = Standard_Standard then
4546             exit;
4547          else
4548             Scop := Scope (Scop);
4549          end if;
4550       end loop;
4551
4552       return False;
4553    end Contains_Instance_Of;
4554
4555    -----------------------
4556    -- Copy_Generic_Node --
4557    -----------------------
4558
4559    function Copy_Generic_Node
4560      (N             : Node_Id;
4561       Parent_Id     : Node_Id;
4562       Instantiating : Boolean)
4563       return          Node_Id
4564    is
4565       Ent   : Entity_Id;
4566       New_N : Node_Id;
4567
4568       function Copy_Generic_Descendant (D : Union_Id) return Union_Id;
4569       --  Check the given value of one of the Fields referenced by the
4570       --  current node to determine whether to copy it recursively. The
4571       --  field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
4572       --  value (Sloc, Uint, Char) in which case it need not be copied.
4573
4574       procedure Copy_Descendants;
4575       --  Common utility for various nodes.
4576
4577       function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
4578       --  Make copy of element list.
4579
4580       function Copy_Generic_List
4581         (L         : List_Id;
4582          Parent_Id : Node_Id)
4583          return      List_Id;
4584       --  Apply Copy_Node recursively to the members of a node list.
4585
4586       function In_Defining_Unit_Name (Nam : Node_Id) return Boolean;
4587       --  True if an identifier is part of the defining program unit name
4588       --  of a child unit. The entity of such an identifier must be kept
4589       --  (for ASIS use) even though as the name of an enclosing generic
4590       --   it would otherwise not be preserved in the generic tree.
4591
4592       ----------------------
4593       -- Copy_Descendants --
4594       ----------------------
4595
4596       procedure Copy_Descendants is
4597
4598          use Atree.Unchecked_Access;
4599          --  This code section is part of the implementation of an untyped
4600          --  tree traversal, so it needs direct access to node fields.
4601
4602       begin
4603          Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
4604          Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
4605          Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
4606          Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
4607          Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
4608       end Copy_Descendants;
4609
4610       -----------------------------
4611       -- Copy_Generic_Descendant --
4612       -----------------------------
4613
4614       function Copy_Generic_Descendant (D : Union_Id) return Union_Id is
4615       begin
4616          if D = Union_Id (Empty) then
4617             return D;
4618
4619          elsif D in Node_Range then
4620             return Union_Id
4621               (Copy_Generic_Node (Node_Id (D), New_N, Instantiating));
4622
4623          elsif D in List_Range then
4624             return Union_Id (Copy_Generic_List (List_Id (D), New_N));
4625
4626          elsif D in Elist_Range then
4627             return Union_Id (Copy_Generic_Elist (Elist_Id (D)));
4628
4629          --  Nothing else is copyable (e.g. Uint values), return as is
4630
4631          else
4632             return D;
4633          end if;
4634       end Copy_Generic_Descendant;
4635
4636       ------------------------
4637       -- Copy_Generic_Elist --
4638       ------------------------
4639
4640       function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is
4641          M : Elmt_Id;
4642          L : Elist_Id;
4643
4644       begin
4645          if Present (E) then
4646             L := New_Elmt_List;
4647             M := First_Elmt (E);
4648             while Present (M) loop
4649                Append_Elmt
4650                  (Copy_Generic_Node (Node (M), Empty, Instantiating), L);
4651                Next_Elmt (M);
4652             end loop;
4653
4654             return L;
4655
4656          else
4657             return No_Elist;
4658          end if;
4659       end Copy_Generic_Elist;
4660
4661       -----------------------
4662       -- Copy_Generic_List --
4663       -----------------------
4664
4665       function Copy_Generic_List
4666         (L         : List_Id;
4667          Parent_Id : Node_Id)
4668          return      List_Id
4669       is
4670          N     : Node_Id;
4671          New_L : List_Id;
4672
4673       begin
4674          if Present (L) then
4675             New_L := New_List;
4676             Set_Parent (New_L, Parent_Id);
4677
4678             N := First (L);
4679             while Present (N) loop
4680                Append (Copy_Generic_Node (N, Empty, Instantiating), New_L);
4681                Next (N);
4682             end loop;
4683
4684             return New_L;
4685
4686          else
4687             return No_List;
4688          end if;
4689       end Copy_Generic_List;
4690
4691       ---------------------------
4692       -- In_Defining_Unit_Name --
4693       ---------------------------
4694
4695       function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is
4696       begin
4697          return Present (Parent (Nam))
4698            and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name
4699                       or else
4700                         (Nkind (Parent (Nam)) = N_Expanded_Name
4701                           and then In_Defining_Unit_Name (Parent (Nam))));
4702       end In_Defining_Unit_Name;
4703
4704    --  Start of processing for Copy_Generic_Node
4705
4706    begin
4707       if N = Empty then
4708          return N;
4709       end if;
4710
4711       New_N := New_Copy (N);
4712
4713       if Instantiating then
4714          Adjust_Instantiation_Sloc (New_N, S_Adjustment);
4715       end if;
4716
4717       if not Is_List_Member (N) then
4718          Set_Parent (New_N, Parent_Id);
4719       end if;
4720
4721       --  If defining identifier, then all fields have been copied already
4722
4723       if Nkind (New_N) in N_Entity then
4724          null;
4725
4726       --  Special casing for identifiers and other entity names and operators
4727
4728       elsif     Nkind (New_N) = N_Identifier
4729         or else Nkind (New_N) = N_Character_Literal
4730         or else Nkind (New_N) = N_Expanded_Name
4731         or else Nkind (New_N) = N_Operator_Symbol
4732         or else Nkind (New_N) in N_Op
4733       then
4734          if not Instantiating then
4735
4736             --  Link both nodes in order to assign subsequently the
4737             --  entity of the copy to the original node, in case this
4738             --  is a global reference.
4739
4740             Set_Associated_Node (N, New_N);
4741
4742             --  If we are within an instantiation, this is a nested generic
4743             --  that has already been analyzed at the point of definition. We
4744             --  must preserve references that were global to the enclosing
4745             --  parent at that point. Other occurrences, whether global or
4746             --  local to the current generic, must be resolved anew, so we
4747             --  reset the entity in the generic copy. A global reference has
4748             --  a smaller depth than the parent, or else the same depth in
4749             --  case both are distinct compilation units.
4750
4751             --  It is also possible for Current_Instantiated_Parent to be
4752             --  defined, and for this not to be a nested generic, namely
4753             --  if the unit is loaded through Rtsfind. In that case, the
4754             --  entity of New_N is only a link to the associated node, and
4755             --  not a defining occurrence.
4756
4757             --  The entities for parent units in the defining_program_unit
4758             --  of a generic child unit are established when the context of
4759             --  the unit is first analyzed, before the generic copy is made.
4760             --  They are preserved in the copy for use in ASIS queries.
4761
4762             Ent := Entity (New_N);
4763
4764             if No (Current_Instantiated_Parent.Gen_Id) then
4765                if No (Ent)
4766                  or else Nkind (Ent) /= N_Defining_Identifier
4767                  or else not In_Defining_Unit_Name (N)
4768                then
4769                   Set_Associated_Node (New_N, Empty);
4770                end if;
4771
4772             elsif No (Ent)
4773               or else
4774                 not (Nkind (Ent) = N_Defining_Identifier
4775                        or else
4776                      Nkind (Ent) = N_Defining_Character_Literal
4777                        or else
4778                      Nkind (Ent) = N_Defining_Operator_Symbol)
4779               or else No (Scope (Ent))
4780               or else Scope (Ent) = Current_Instantiated_Parent.Gen_Id
4781               or else (Scope_Depth (Scope (Ent)) >
4782                              Scope_Depth (Current_Instantiated_Parent.Gen_Id)
4783                          and then
4784                        Get_Source_Unit (Ent) =
4785                        Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
4786             then
4787                Set_Associated_Node (New_N, Empty);
4788             end if;
4789
4790          --  Case of instantiating identifier or some other name or operator
4791
4792          else
4793             --  If the associated node is still defined, the entity in
4794             --  it is global, and must be copied to the instance.
4795             --  If this copy is being made for a body to inline, it is
4796             --  applied to an instantiated tree, and the entity is already
4797             --  present and must be also preserved.
4798
4799             declare
4800                Assoc : constant Node_Id := Get_Associated_Node (N);
4801             begin
4802                if Present (Assoc) then
4803                   if Nkind (Assoc) = Nkind (N) then
4804                      Set_Entity (New_N, Entity (Assoc));
4805                      Check_Private_View (N);
4806
4807                   elsif Nkind (Assoc) = N_Function_Call then
4808                      Set_Entity (New_N, Entity (Name (Assoc)));
4809
4810                   elsif (Nkind (Assoc) = N_Defining_Identifier
4811                           or else Nkind (Assoc) = N_Defining_Character_Literal
4812                           or else Nkind (Assoc) = N_Defining_Operator_Symbol)
4813                     and then Expander_Active
4814                   then
4815                      --  Inlining case: we are copying a tree that contains
4816                      --  global entities, which are preserved in the copy
4817                      --  to be used for subsequent inlining.
4818
4819                      null;
4820
4821                   else
4822                      Set_Entity (New_N, Empty);
4823                   end if;
4824                end if;
4825             end;
4826          end if;
4827
4828          --  For expanded name, we must copy the Prefix and Selector_Name
4829
4830          if Nkind (N) = N_Expanded_Name then
4831             Set_Prefix
4832               (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
4833
4834             Set_Selector_Name (New_N,
4835               Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
4836
4837          --  For operators, we must copy the right operand
4838
4839          elsif Nkind (N) in N_Op then
4840             Set_Right_Opnd (New_N,
4841               Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
4842
4843             --  And for binary operators, the left operand as well
4844
4845             if Nkind (N) in N_Binary_Op then
4846                Set_Left_Opnd (New_N,
4847                  Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
4848             end if;
4849          end if;
4850
4851       --  Special casing for stubs
4852
4853       elsif Nkind (N) in N_Body_Stub then
4854
4855          --  In any case, we must copy the specification or defining
4856          --  identifier as appropriate.
4857
4858          if Nkind (N) = N_Subprogram_Body_Stub then
4859             Set_Specification (New_N,
4860               Copy_Generic_Node (Specification (N), New_N, Instantiating));
4861
4862          else
4863             Set_Defining_Identifier (New_N,
4864               Copy_Generic_Node
4865                 (Defining_Identifier (N), New_N, Instantiating));
4866          end if;
4867
4868          --  If we are not instantiating, then this is where we load and
4869          --  analyze subunits, i.e. at the point where the stub occurs. A
4870          --  more permissivle system might defer this analysis to the point
4871          --  of instantiation, but this seems to complicated for now.
4872
4873          if not Instantiating then
4874             declare
4875                Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
4876                Subunit      : Node_Id;
4877                Unum         : Unit_Number_Type;
4878                New_Body     : Node_Id;
4879
4880             begin
4881                Unum :=
4882                  Load_Unit
4883                    (Load_Name  => Subunit_Name,
4884                     Required   => False,
4885                     Subunit    => True,
4886                     Error_Node => N);
4887
4888                --  If the proper body is not found, a warning message will
4889                --  be emitted when analyzing the stub, or later at the the
4890                --  point of instantiation. Here we just leave the stub as is.
4891
4892                if Unum = No_Unit then
4893                   Subunits_Missing := True;
4894                   goto Subunit_Not_Found;
4895                end if;
4896
4897                Subunit := Cunit (Unum);
4898
4899                if Nkind (Unit (Subunit)) /= N_Subunit then
4900                   Error_Msg_Sloc := Sloc (N);
4901                   Error_Msg_N
4902                     ("expected SEPARATE subunit to complete stub at#,"
4903                        & " found child unit", Subunit);
4904                   goto Subunit_Not_Found;
4905                end if;
4906
4907                --  We must create a generic copy of the subunit, in order
4908                --  to perform semantic analysis on it, and we must replace
4909                --  the stub in the original generic unit with the subunit,
4910                --  in order to preserve non-local references within.
4911
4912                --  Only the proper body needs to be copied. Library_Unit and
4913                --  context clause are simply inherited by the generic copy.
4914                --  Note that the copy (which may be recursive if there are
4915                --  nested subunits) must be done first, before attaching it
4916                --  to the enclosing generic.
4917
4918                New_Body :=
4919                  Copy_Generic_Node
4920                    (Proper_Body (Unit (Subunit)),
4921                     Empty, Instantiating => False);
4922
4923                --  Now place the original proper body in the original
4924                --  generic unit. This is a body, not a compilation unit.
4925
4926                Rewrite (N, Proper_Body (Unit (Subunit)));
4927                Set_Is_Compilation_Unit (Defining_Entity (N), False);
4928                Set_Was_Originally_Stub (N);
4929
4930                --  Finally replace the body of the subunit with its copy,
4931                --  and make this new subunit into the library unit of the
4932                --  generic copy, which does not have stubs any longer.
4933
4934                Set_Proper_Body (Unit (Subunit), New_Body);
4935                Set_Library_Unit (New_N, Subunit);
4936                Inherit_Context (Unit (Subunit), N);
4937             end;
4938
4939          --  If we are instantiating, this must be an error case, since
4940          --  otherwise we would have replaced the stub node by the proper
4941          --  body that corresponds. So just ignore it in the copy (i.e.
4942          --  we have copied it, and that is good enough).
4943
4944          else
4945             null;
4946          end if;
4947
4948          <<Subunit_Not_Found>> null;
4949
4950       --  If the node is a compilation unit, it is the subunit of a stub,
4951       --  which has been loaded already (see code below). In this case,
4952       --  the library unit field of N points to the parent unit (which
4953       --  is a compilation unit) and need not (and cannot!) be copied.
4954
4955       --  When the proper body of the stub is analyzed, thie library_unit
4956       --  link is used to establish the proper context (see sem_ch10).
4957
4958       --  The other fields of a compilation unit are copied as usual
4959
4960       elsif Nkind (N) = N_Compilation_Unit then
4961
4962          --  This code can only be executed when not instantiating, because
4963          --  in the copy made for an instantiation, the compilation unit
4964          --  node has disappeared at the point that a stub is replaced by
4965          --  its proper body.
4966
4967          pragma Assert (not Instantiating);
4968
4969          Set_Context_Items (New_N,
4970            Copy_Generic_List (Context_Items (N), New_N));
4971
4972          Set_Unit (New_N,
4973            Copy_Generic_Node (Unit (N), New_N, False));
4974
4975          Set_First_Inlined_Subprogram (New_N,
4976            Copy_Generic_Node
4977              (First_Inlined_Subprogram (N), New_N, False));
4978
4979          Set_Aux_Decls_Node (New_N,
4980            Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
4981
4982       --  For an assignment node, the assignment is known to be semantically
4983       --  legal if we are instantiating the template. This avoids incorrect
4984       --  diagnostics in generated code.
4985
4986       elsif Nkind (N) = N_Assignment_Statement then
4987
4988          --  Copy name and expression fields in usual manner
4989
4990          Set_Name (New_N,
4991            Copy_Generic_Node (Name (N), New_N, Instantiating));
4992
4993          Set_Expression (New_N,
4994            Copy_Generic_Node (Expression (N), New_N, Instantiating));
4995
4996          if Instantiating then
4997             Set_Assignment_OK (Name (New_N), True);
4998          end if;
4999
5000       elsif Nkind (N) = N_Aggregate
5001               or else Nkind (N) = N_Extension_Aggregate
5002       then
5003
5004          if not Instantiating then
5005             Set_Associated_Node (N, New_N);
5006
5007          else
5008             if Present (Get_Associated_Node (N))
5009               and then Nkind (Get_Associated_Node (N)) = Nkind (N)
5010             then
5011                --  In the generic the aggregate has some composite type. If at
5012                --  the point of instantiation the type has a private view,
5013                --  install the full view (and that of its ancestors, if any).
5014
5015                declare
5016                   T   : Entity_Id := (Etype (Get_Associated_Node (New_N)));
5017                   Rt  : Entity_Id;
5018
5019                begin
5020                   if Present (T)
5021                     and then Is_Private_Type (T)
5022                   then
5023                      Switch_View (T);
5024                   end if;
5025
5026                   if Present (T)
5027                     and then Is_Tagged_Type (T)
5028                     and then Is_Derived_Type (T)
5029                   then
5030                      Rt := Root_Type (T);
5031
5032                      loop
5033                         T := Etype (T);
5034
5035                         if Is_Private_Type (T) then
5036                            Switch_View (T);
5037                         end if;
5038
5039                         exit when T = Rt;
5040                      end loop;
5041                   end if;
5042                end;
5043             end if;
5044          end if;
5045
5046          --  Do not copy the associated node, which points to
5047          --  the generic copy of the aggregate.
5048
5049          declare
5050             use Atree.Unchecked_Access;
5051             --  This code section is part of the implementation of an untyped
5052             --  tree traversal, so it needs direct access to node fields.
5053
5054          begin
5055             Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
5056             Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
5057             Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
5058             Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
5059          end;
5060
5061       --  Allocators do not have an identifier denoting the access type,
5062       --  so we must locate it through the expression to check whether
5063       --  the views are consistent.
5064
5065       elsif Nkind (N) = N_Allocator
5066         and then Nkind (Expression (N)) = N_Qualified_Expression
5067         and then Is_Entity_Name (Subtype_Mark (Expression (N)))
5068         and then Instantiating
5069       then
5070          declare
5071             T     : constant Node_Id :=
5072                       Get_Associated_Node (Subtype_Mark (Expression (N)));
5073             Acc_T : Entity_Id;
5074
5075          begin
5076             if Present (T) then
5077                --  Retrieve the allocator node in the generic copy.
5078
5079                Acc_T := Etype (Parent (Parent (T)));
5080                if Present (Acc_T)
5081                  and then Is_Private_Type (Acc_T)
5082                then
5083                   Switch_View (Acc_T);
5084                end if;
5085             end if;
5086
5087             Copy_Descendants;
5088          end;
5089
5090       --  For a proper body, we must catch the case of a proper body that
5091       --  replaces a stub. This represents the point at which a separate
5092       --  compilation unit, and hence template file, may be referenced, so
5093       --  we must make a new source instantiation entry for the template
5094       --  of the subunit, and ensure that all nodes in the subunit are
5095       --  adjusted using this new source instantiation entry.
5096
5097       elsif Nkind (N) in N_Proper_Body then
5098          declare
5099             Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
5100
5101          begin
5102             if Instantiating and then Was_Originally_Stub (N) then
5103                Create_Instantiation_Source
5104                  (Instantiation_Node,
5105                   Defining_Entity (N),
5106                   False,
5107                   S_Adjustment);
5108             end if;
5109
5110             --  Now copy the fields of the proper body, using the new
5111             --  adjustment factor if one was needed as per test above.
5112
5113             Copy_Descendants;
5114
5115             --  Restore the original adjustment factor in case changed
5116
5117             S_Adjustment := Save_Adjustment;
5118          end;
5119
5120       --  Don't copy Ident or Comment pragmas, since the comment belongs
5121       --  to the generic unit, not to the instantiating unit.
5122
5123       elsif Nkind (N) = N_Pragma
5124         and then Instantiating
5125       then
5126          declare
5127             Prag_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
5128
5129          begin
5130             if Prag_Id = Pragma_Ident
5131               or else Prag_Id = Pragma_Comment
5132             then
5133                New_N := Make_Null_Statement (Sloc (N));
5134
5135             else
5136                Copy_Descendants;
5137             end if;
5138          end;
5139
5140       elsif Nkind (N) = N_Integer_Literal
5141         or else Nkind (N) = N_Real_Literal
5142       then
5143          --  No descendant fields need traversing
5144
5145          null;
5146
5147       --  For the remaining nodes, copy recursively their descendants
5148
5149       else
5150          Copy_Descendants;
5151
5152          if Instantiating
5153            and then Nkind (N) = N_Subprogram_Body
5154          then
5155             Set_Generic_Parent (Specification (New_N), N);
5156          end if;
5157       end if;
5158
5159       return New_N;
5160    end Copy_Generic_Node;
5161
5162    ----------------------------
5163    -- Denotes_Formal_Package --
5164    ----------------------------
5165
5166    function Denotes_Formal_Package (Pack : Entity_Id) return Boolean is
5167       Par  : constant Entity_Id := Current_Instantiated_Parent.Act_Id;
5168       Scop : constant Entity_Id := Scope (Pack);
5169       E    : Entity_Id;
5170
5171    begin
5172       if Ekind (Scop) = E_Generic_Package
5173         or else Nkind (Unit_Declaration_Node (Scop)) =
5174                                          N_Generic_Subprogram_Declaration
5175       then
5176          return True;
5177
5178       elsif Nkind (Parent (Pack)) = N_Formal_Package_Declaration then
5179          return True;
5180
5181       elsif No (Par) then
5182          return False;
5183
5184       else
5185          --  Check whether this package is associated with a formal
5186          --  package of the enclosing instantiation. Iterate over the
5187          --  list of renamings.
5188
5189          E := First_Entity (Par);
5190          while Present (E) loop
5191             if Ekind (E) /= E_Package
5192               or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
5193             then
5194                null;
5195             elsif Renamed_Object (E) = Par then
5196                return False;
5197
5198             elsif Renamed_Object (E) = Pack then
5199                return True;
5200             end if;
5201
5202             Next_Entity (E);
5203          end loop;
5204
5205          return False;
5206       end if;
5207    end Denotes_Formal_Package;
5208
5209    -----------------
5210    -- End_Generic --
5211    -----------------
5212
5213    procedure End_Generic is
5214    begin
5215       --  ??? More things could be factored out in this
5216       --  routine. Should probably be done at a later stage.
5217
5218       Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last);
5219       Generic_Flags.Decrement_Last;
5220
5221       Expander_Mode_Restore;
5222    end End_Generic;
5223
5224    ----------------------
5225    -- Find_Actual_Type --
5226    ----------------------
5227
5228    function Find_Actual_Type
5229      (Typ       : Entity_Id;
5230       Gen_Scope : Entity_Id)
5231       return      Entity_Id
5232    is
5233       T : Entity_Id;
5234
5235    begin
5236       if not Is_Child_Unit (Gen_Scope) then
5237          return Get_Instance_Of (Typ);
5238
5239       elsif not Is_Generic_Type (Typ)
5240         or else Scope (Typ) = Gen_Scope
5241       then
5242          return Get_Instance_Of (Typ);
5243
5244       else
5245          T := Current_Entity (Typ);
5246          while Present (T) loop
5247             if In_Open_Scopes (Scope (T)) then
5248                return T;
5249             end if;
5250
5251             T := Homonym (T);
5252          end loop;
5253
5254          return Typ;
5255       end if;
5256    end Find_Actual_Type;
5257
5258    ----------------------------
5259    -- Freeze_Subprogram_Body --
5260    ----------------------------
5261
5262    procedure Freeze_Subprogram_Body
5263      (Inst_Node : Node_Id;
5264       Gen_Body  : Node_Id;
5265       Pack_Id   : Entity_Id)
5266   is
5267       F_Node   : Node_Id;
5268       Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
5269       Par      : constant Entity_Id := Scope (Gen_Unit);
5270       Enc_G    : Entity_Id;
5271       Enc_I    : Node_Id;
5272       E_G_Id   : Entity_Id;
5273
5274       function Earlier (N1, N2 : Node_Id) return Boolean;
5275       --  Yields True if N1 and N2 appear in the same compilation unit,
5276       --  ignoring subunits, and if N1 is to the left of N2 in a left-to-right
5277       --  traversal of the tree for the unit.
5278
5279       function Enclosing_Body (N : Node_Id) return Node_Id;
5280       --  Find innermost package body that encloses the given node, and which
5281       --  is not a compilation unit. Freeze nodes for the instance, or for its
5282       --  enclosing body, may be inserted after the enclosing_body of the
5283       --  generic unit.
5284
5285       function Package_Freeze_Node (B : Node_Id) return Node_Id;
5286       --  Find entity for given package body, and locate or create a freeze
5287       --  node for it.
5288
5289       function True_Parent (N : Node_Id) return Node_Id;
5290       --  For a subunit, return parent of corresponding stub.
5291
5292       -------------
5293       -- Earlier --
5294       -------------
5295
5296       function Earlier (N1, N2 : Node_Id) return Boolean is
5297          D1 : Integer := 0;
5298          D2 : Integer := 0;
5299          P1 : Node_Id := N1;
5300          P2 : Node_Id := N2;
5301
5302          procedure Find_Depth (P : in out Node_Id; D : in out Integer);
5303          --  Find distance from given node to enclosing compilation unit.
5304
5305          ----------------
5306          -- Find_Depth --
5307          ----------------
5308
5309          procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
5310          begin
5311             while Present (P)
5312               and then Nkind (P) /= N_Compilation_Unit
5313             loop
5314                P := True_Parent (P);
5315                D := D + 1;
5316             end loop;
5317          end Find_Depth;
5318
5319       --  Start of procesing for Earlier
5320
5321       begin
5322          Find_Depth (P1, D1);
5323          Find_Depth (P2, D2);
5324
5325          if P1 /= P2 then
5326             return False;
5327          else
5328             P1 := N1;
5329             P2 := N2;
5330          end if;
5331
5332          while D1 > D2 loop
5333             P1 := True_Parent (P1);
5334             D1 := D1 - 1;
5335          end loop;
5336
5337          while D2 > D1 loop
5338             P2 := True_Parent (P2);
5339             D2 := D2 - 1;
5340          end loop;
5341
5342          --  At this point P1 and P2 are at the same distance from the root.
5343          --  We examine their parents until we find a common declarative
5344          --  list, at which point we can establish their relative placement
5345          --  by comparing their ultimate slocs. If we reach the root,
5346          --  N1 and N2 do not descend from the same declarative list (e.g.
5347          --  one is nested in the declarative part and the other is in a block
5348          --  in the statement part) and the earlier one is already frozen.
5349
5350          while not Is_List_Member (P1)
5351            or else not Is_List_Member (P2)
5352            or else List_Containing (P1) /= List_Containing (P2)
5353          loop
5354             P1 := True_Parent (P1);
5355             P2 := True_Parent (P2);
5356
5357             if Nkind (Parent (P1)) = N_Subunit then
5358                P1 := Corresponding_Stub (Parent (P1));
5359             end if;
5360
5361             if Nkind (Parent (P2)) = N_Subunit then
5362                P2 := Corresponding_Stub (Parent (P2));
5363             end if;
5364
5365             if P1 = P2 then
5366                return False;
5367             end if;
5368          end loop;
5369
5370          return
5371            Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2));
5372       end Earlier;
5373
5374       --------------------
5375       -- Enclosing_Body --
5376       --------------------
5377
5378       function Enclosing_Body (N : Node_Id) return Node_Id is
5379          P : Node_Id := Parent (N);
5380
5381       begin
5382          while Present (P)
5383            and then Nkind (Parent (P)) /= N_Compilation_Unit
5384          loop
5385             if Nkind (P) = N_Package_Body then
5386
5387                if Nkind (Parent (P)) = N_Subunit then
5388                   return Corresponding_Stub (Parent (P));
5389                else
5390                   return P;
5391                end if;
5392             end if;
5393
5394             P := True_Parent (P);
5395          end loop;
5396
5397          return Empty;
5398       end Enclosing_Body;
5399
5400       -------------------------
5401       -- Package_Freeze_Node --
5402       -------------------------
5403
5404       function Package_Freeze_Node (B : Node_Id) return Node_Id is
5405          Id : Entity_Id;
5406
5407       begin
5408          if Nkind (B) = N_Package_Body then
5409             Id := Corresponding_Spec (B);
5410
5411          else pragma Assert (Nkind (B) = N_Package_Body_Stub);
5412             Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B))));
5413          end if;
5414
5415          Ensure_Freeze_Node (Id);
5416          return Freeze_Node (Id);
5417       end Package_Freeze_Node;
5418
5419       -----------------
5420       -- True_Parent --
5421       -----------------
5422
5423       function True_Parent (N : Node_Id) return Node_Id is
5424       begin
5425          if Nkind (Parent (N)) = N_Subunit then
5426             return Parent (Corresponding_Stub (Parent (N)));
5427          else
5428             return Parent (N);
5429          end if;
5430       end True_Parent;
5431
5432    --  Start of processing of Freeze_Subprogram_Body
5433
5434    begin
5435       --  If the instance and the generic body appear within the same
5436       --  unit, and the instance preceeds the generic, the freeze node for
5437       --  the instance must appear after that of the generic. If the generic
5438       --  is nested within another instance I2, then current instance must
5439       --  be frozen after I2. In both cases, the freeze nodes are those of
5440       --  enclosing packages. Otherwise, the freeze node is placed at the end
5441       --  of the current declarative part.
5442
5443       Enc_G  := Enclosing_Body (Gen_Body);
5444       Enc_I  := Enclosing_Body (Inst_Node);
5445       Ensure_Freeze_Node (Pack_Id);
5446       F_Node := Freeze_Node (Pack_Id);
5447
5448       if Is_Generic_Instance (Par)
5449         and then Present (Freeze_Node (Par))
5450         and then
5451           In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
5452       then
5453          if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
5454
5455             --  The parent was a premature instantiation. Insert freeze
5456             --  node at the end the current declarative part.
5457
5458             Insert_After_Last_Decl (Inst_Node, F_Node);
5459
5460          else
5461             Insert_After (Freeze_Node (Par), F_Node);
5462          end if;
5463
5464       --  The body enclosing the instance should be frozen after the body
5465       --  that includes the generic, because the body of the instance may
5466       --  make references to entities therein. If the two are not in the
5467       --  same declarative part, or if the one enclosing the instance is
5468       --  frozen already, freeze the instance at the end of the current
5469       --  declarative part.
5470
5471       elsif Is_Generic_Instance (Par)
5472         and then Present (Freeze_Node (Par))
5473         and then Present (Enc_I)
5474       then
5475          if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I)
5476            or else
5477              (Nkind (Enc_I) = N_Package_Body
5478                and then
5479              In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
5480          then
5481             --  The enclosing package may contain several instances. Rather
5482             --  than computing the earliest point at which to insert its
5483             --  freeze node, we place it at the end of the declarative part
5484             --  of the parent of the generic.
5485
5486             Insert_After_Last_Decl
5487               (Freeze_Node (Par), Package_Freeze_Node (Enc_I));
5488          end if;
5489
5490          Insert_After_Last_Decl (Inst_Node, F_Node);
5491
5492       elsif Present (Enc_G)
5493         and then Present (Enc_I)
5494         and then Enc_G /= Enc_I
5495         and then Earlier (Inst_Node, Gen_Body)
5496       then
5497          if Nkind (Enc_G) = N_Package_Body then
5498             E_G_Id := Corresponding_Spec (Enc_G);
5499          else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
5500             E_G_Id :=
5501               Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
5502          end if;
5503
5504          --  Freeze package that encloses instance, and place node after
5505          --  package that encloses generic. If enclosing package is already
5506          --  frozen we have to assume it is at the proper place. This may
5507          --  be a potential ABE that requires dynamic checking.
5508
5509          Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I));
5510
5511          --  Freeze enclosing subunit before instance
5512
5513          Ensure_Freeze_Node (E_G_Id);
5514
5515          if not Is_List_Member (Freeze_Node (E_G_Id)) then
5516             Insert_After (Enc_G, Freeze_Node (E_G_Id));
5517          end if;
5518
5519          Insert_After_Last_Decl (Inst_Node, F_Node);
5520
5521       else
5522          --  If none of the above, insert freeze node at the end of the
5523          --  current declarative part.
5524
5525          Insert_After_Last_Decl (Inst_Node, F_Node);
5526       end if;
5527    end Freeze_Subprogram_Body;
5528
5529    ----------------
5530    -- Get_Gen_Id --
5531    ----------------
5532
5533    function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is
5534    begin
5535       return Generic_Renamings.Table (E).Gen_Id;
5536    end Get_Gen_Id;
5537
5538    ---------------------
5539    -- Get_Instance_Of --
5540    ---------------------
5541
5542    function Get_Instance_Of (A : Entity_Id) return Entity_Id is
5543       Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A);
5544
5545    begin
5546       if Res /= Assoc_Null then
5547          return Generic_Renamings.Table (Res).Act_Id;
5548       else
5549          --  On exit, entity is not instantiated: not a generic parameter,
5550          --  or else parameter of an inner generic unit.
5551
5552          return A;
5553       end if;
5554    end Get_Instance_Of;
5555
5556    ------------------------------------
5557    -- Get_Package_Instantiation_Node --
5558    ------------------------------------
5559
5560    function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
5561       Decl : Node_Id := Unit_Declaration_Node (A);
5562       Inst : Node_Id;
5563
5564    begin
5565       --  If the instantiation is a compilation unit that does not need a
5566       --  body then the instantiation node has been rewritten as a package
5567       --  declaration for the instance, and we return the original node.
5568
5569       --  If it is a compilation unit and the instance node has not been
5570       --  rewritten, then it is still the unit of the compilation. Finally,
5571       --  if a body is present, this is a parent of the main unit whose body
5572       --  has been compiled for inlining purposes, and the instantiation node
5573       --  has been rewritten with the instance body.
5574
5575       --  Otherwise the instantiation node appears after the declaration.
5576       --  If the entity is a formal package, the declaration may have been
5577       --  rewritten as a generic declaration (in the case of a formal with a
5578       --  box) or left as a formal package declaration if it has actuals, and
5579       --  is found with a forward search.
5580
5581       if Nkind (Parent (Decl)) = N_Compilation_Unit then
5582          if Nkind (Decl) = N_Package_Declaration
5583            and then Present (Corresponding_Body (Decl))
5584          then
5585             Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
5586          end if;
5587
5588          if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
5589             return Original_Node (Decl);
5590          else
5591             return Unit (Parent (Decl));
5592          end if;
5593
5594       elsif Nkind (Decl) = N_Generic_Package_Declaration
5595         and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration
5596       then
5597          return Original_Node (Decl);
5598
5599       else
5600          Inst := Next (Decl);
5601          while Nkind (Inst) /= N_Package_Instantiation
5602            and then Nkind (Inst) /= N_Formal_Package_Declaration
5603          loop
5604             Next (Inst);
5605          end loop;
5606
5607          return Inst;
5608       end if;
5609    end Get_Package_Instantiation_Node;
5610
5611    ------------------------
5612    -- Has_Been_Exchanged --
5613    ------------------------
5614
5615    function Has_Been_Exchanged (E : Entity_Id) return Boolean is
5616       Next : Elmt_Id := First_Elmt (Exchanged_Views);
5617
5618    begin
5619       while Present (Next) loop
5620          if Full_View (Node (Next)) = E then
5621             return True;
5622          end if;
5623
5624          Next_Elmt (Next);
5625       end loop;
5626
5627       return False;
5628    end Has_Been_Exchanged;
5629
5630    ----------
5631    -- Hash --
5632    ----------
5633
5634    function Hash (F : Entity_Id) return HTable_Range is
5635    begin
5636       return HTable_Range (F mod HTable_Size);
5637    end Hash;
5638
5639    ------------------------
5640    -- Hide_Current_Scope --
5641    ------------------------
5642
5643    procedure Hide_Current_Scope is
5644       C : constant Entity_Id := Current_Scope;
5645       E : Entity_Id;
5646
5647    begin
5648       Set_Is_Hidden_Open_Scope (C);
5649       E := First_Entity (C);
5650
5651       while Present (E) loop
5652          if Is_Immediately_Visible (E) then
5653             Set_Is_Immediately_Visible (E, False);
5654             Append_Elmt (E, Hidden_Entities);
5655          end if;
5656
5657          Next_Entity (E);
5658       end loop;
5659
5660       --  Make the scope name invisible as well. This is necessary, but
5661       --  might conflict with calls to Rtsfind later on, in case the scope
5662       --  is a predefined one. There is no clean solution to this problem, so
5663       --  for now we depend on the user not redefining Standard itself in one
5664       --  of the parent units.
5665
5666       if Is_Immediately_Visible (C)
5667         and then C /= Standard_Standard
5668       then
5669          Set_Is_Immediately_Visible (C, False);
5670          Append_Elmt (C, Hidden_Entities);
5671       end if;
5672
5673    end Hide_Current_Scope;
5674
5675    --------------
5676    -- Init_Env --
5677    --------------
5678
5679    procedure Init_Env is
5680       Saved : Instance_Env;
5681
5682    begin
5683       Saved.Ada_Version         := Ada_Version;
5684       Saved.Instantiated_Parent := Current_Instantiated_Parent;
5685       Saved.Exchanged_Views     := Exchanged_Views;
5686       Saved.Hidden_Entities     := Hidden_Entities;
5687       Saved.Current_Sem_Unit    := Current_Sem_Unit;
5688       Instance_Envs.Increment_Last;
5689       Instance_Envs.Table (Instance_Envs.Last) := Saved;
5690
5691       Exchanged_Views := New_Elmt_List;
5692       Hidden_Entities := New_Elmt_List;
5693
5694       --  Make dummy entry for Instantiated parent. If generic unit is
5695       --  legal, this is set properly in Set_Instance_Env.
5696
5697       Current_Instantiated_Parent :=
5698         (Current_Scope, Current_Scope, Assoc_Null);
5699    end Init_Env;
5700
5701    ------------------------------
5702    -- In_Same_Declarative_Part --
5703    ------------------------------
5704
5705    function In_Same_Declarative_Part
5706      (F_Node : Node_Id;
5707       Inst   : Node_Id)
5708       return   Boolean
5709    is
5710       Decls : constant Node_Id := Parent (F_Node);
5711       Nod   : Node_Id := Parent (Inst);
5712
5713    begin
5714       while Present (Nod) loop
5715          if Nod = Decls then
5716             return True;
5717
5718          elsif Nkind (Nod) = N_Subprogram_Body
5719            or else Nkind (Nod) = N_Package_Body
5720            or else Nkind (Nod) = N_Task_Body
5721            or else Nkind (Nod) = N_Protected_Body
5722            or else Nkind (Nod) = N_Block_Statement
5723          then
5724             return False;
5725
5726          elsif Nkind (Nod) = N_Subunit then
5727             Nod :=  Corresponding_Stub (Nod);
5728
5729          elsif Nkind (Nod) = N_Compilation_Unit then
5730             return False;
5731          else
5732             Nod := Parent (Nod);
5733          end if;
5734       end loop;
5735
5736       return False;
5737    end In_Same_Declarative_Part;
5738
5739    ---------------------
5740    -- Inherit_Context --
5741    ---------------------
5742
5743    procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is
5744       Current_Context : List_Id;
5745       Current_Unit    : Node_Id;
5746       Item            : Node_Id;
5747       New_I           : Node_Id;
5748
5749    begin
5750       if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then
5751
5752          --  The inherited context is attached to the enclosing compilation
5753          --  unit. This is either the main unit, or the declaration for the
5754          --  main unit (in case the instantation appears within the package
5755          --  declaration and the main unit is its body).
5756
5757          Current_Unit := Parent (Inst);
5758          while Present (Current_Unit)
5759            and then Nkind (Current_Unit) /= N_Compilation_Unit
5760          loop
5761             Current_Unit := Parent (Current_Unit);
5762          end loop;
5763
5764          Current_Context := Context_Items (Current_Unit);
5765
5766          Item := First (Context_Items (Parent (Gen_Decl)));
5767          while Present (Item) loop
5768             if Nkind (Item) = N_With_Clause then
5769                New_I := New_Copy (Item);
5770                Set_Implicit_With (New_I, True);
5771                Append (New_I, Current_Context);
5772             end if;
5773
5774             Next (Item);
5775          end loop;
5776       end if;
5777    end Inherit_Context;
5778
5779    ----------------
5780    -- Initialize --
5781    ----------------
5782
5783    procedure Initialize is
5784    begin
5785       Generic_Renamings.Init;
5786       Instance_Envs.Init;
5787       Generic_Flags.Init;
5788       Generic_Renamings_HTable.Reset;
5789       Circularity_Detected := False;
5790       Exchanged_Views      := No_Elist;
5791       Hidden_Entities      := No_Elist;
5792    end Initialize;
5793
5794    ----------------------------
5795    -- Insert_After_Last_Decl --
5796    ----------------------------
5797
5798    procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
5799       L : List_Id          := List_Containing (N);
5800       P : constant Node_Id := Parent (L);
5801
5802    begin
5803       if not Is_List_Member (F_Node) then
5804          if Nkind (P) = N_Package_Specification
5805            and then L = Visible_Declarations (P)
5806            and then Present (Private_Declarations (P))
5807            and then not Is_Empty_List (Private_Declarations (P))
5808          then
5809             L := Private_Declarations (P);
5810          end if;
5811
5812          Insert_After (Last (L), F_Node);
5813       end if;
5814    end Insert_After_Last_Decl;
5815
5816    ------------------
5817    -- Install_Body --
5818    ------------------
5819
5820    procedure Install_Body
5821      (Act_Body : Node_Id;
5822       N        : Node_Id;
5823       Gen_Body : Node_Id;
5824       Gen_Decl : Node_Id)
5825    is
5826       Act_Id    : constant Entity_Id := Corresponding_Spec (Act_Body);
5827       Act_Unit  : constant Node_Id   := Unit (Cunit (Get_Source_Unit (N)));
5828       Gen_Id    : constant Entity_Id := Corresponding_Spec (Gen_Body);
5829       Par       : constant Entity_Id := Scope (Gen_Id);
5830       Gen_Unit  : constant Node_Id :=
5831                     Unit (Cunit (Get_Source_Unit (Gen_Decl)));
5832       Orig_Body : Node_Id := Gen_Body;
5833       F_Node    : Node_Id;
5834       Body_Unit : Node_Id;
5835
5836       Must_Delay : Boolean;
5837
5838       function Enclosing_Subp (Id : Entity_Id) return Entity_Id;
5839       --  Find subprogram (if any) that encloses instance and/or generic body.
5840
5841       function True_Sloc (N : Node_Id) return Source_Ptr;
5842       --  If the instance is nested inside a generic unit, the Sloc of the
5843       --  instance indicates the place of the original definition, not the
5844       --  point of the current enclosing instance. Pending a better usage of
5845       --  Slocs to indicate instantiation places, we determine the place of
5846       --  origin of a node by finding the maximum sloc of any ancestor node.
5847       --  Why is this not equivalent fo Top_Level_Location ???
5848
5849       function Enclosing_Subp (Id : Entity_Id) return Entity_Id is
5850          Scop : Entity_Id := Scope (Id);
5851
5852       begin
5853          while Scop /= Standard_Standard
5854            and then not Is_Overloadable (Scop)
5855          loop
5856             Scop := Scope (Scop);
5857          end loop;
5858
5859          return Scop;
5860       end Enclosing_Subp;
5861
5862       function True_Sloc (N : Node_Id) return Source_Ptr is
5863          Res : Source_Ptr;
5864          N1  : Node_Id;
5865
5866       begin
5867          Res := Sloc (N);
5868          N1 := N;
5869          while Present (N1) and then N1 /= Act_Unit loop
5870             if Sloc (N1) > Res then
5871                Res := Sloc (N1);
5872             end if;
5873
5874             N1 := Parent (N1);
5875          end loop;
5876
5877          return Res;
5878       end True_Sloc;
5879
5880    --  Start of processing for Install_Body
5881
5882    begin
5883       --  If the body is a subunit, the freeze point is the corresponding
5884       --  stub in the current compilation, not the subunit itself.
5885
5886       if Nkind (Parent (Gen_Body)) = N_Subunit then
5887          Orig_Body :=  Corresponding_Stub (Parent (Gen_Body));
5888       else
5889          Orig_Body := Gen_Body;
5890       end if;
5891
5892       Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body)));
5893
5894       --  If the instantiation and the generic definition appear in the
5895       --  same package declaration, this is an early instantiation.
5896       --  If they appear in the same declarative part, it is an early
5897       --  instantiation only if the generic body appears textually later,
5898       --  and the generic body is also in the main unit.
5899
5900       --  If instance is nested within a subprogram, and the generic body is
5901       --  not, the instance is delayed because the enclosing body is. If
5902       --  instance and body are within the same scope, or the same sub-
5903       --  program body, indicate explicitly that the instance is delayed.
5904
5905       Must_Delay :=
5906         (Gen_Unit = Act_Unit
5907           and then ((Nkind (Gen_Unit) = N_Package_Declaration)
5908                       or else Nkind (Gen_Unit) = N_Generic_Package_Declaration
5909                       or else (Gen_Unit = Body_Unit
5910                                 and then True_Sloc (N) < Sloc (Orig_Body)))
5911           and then Is_In_Main_Unit (Gen_Unit)
5912           and then (Scope (Act_Id) = Scope (Gen_Id)
5913                       or else
5914                     Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id)));
5915
5916       --  If this is an early instantiation, the freeze node is placed after
5917       --  the generic body. Otherwise, if the generic appears in an instance,
5918       --  we cannot freeze the current instance until the outer one is frozen.
5919       --  This is only relevant if the current instance is nested within some
5920       --  inner scope not itself within the outer instance. If this scope is
5921       --  a package body in the same declarative part as the outer instance,
5922       --  then that body needs to be frozen after the outer instance. Finally,
5923       --  if no delay is needed, we place the freeze node at the end of the
5924       --  current declarative part.
5925
5926       if Expander_Active then
5927          Ensure_Freeze_Node (Act_Id);
5928          F_Node := Freeze_Node (Act_Id);
5929
5930          if Must_Delay then
5931             Insert_After (Orig_Body, F_Node);
5932
5933          elsif Is_Generic_Instance (Par)
5934            and then Present (Freeze_Node (Par))
5935            and then Scope (Act_Id) /= Par
5936          then
5937             --  Freeze instance of inner generic after instance of enclosing
5938             --  generic.
5939
5940             if In_Same_Declarative_Part (Freeze_Node (Par), N) then
5941                Insert_After (Freeze_Node (Par), F_Node);
5942
5943             --  Freeze package enclosing instance of inner generic after
5944             --  instance of enclosing generic.
5945
5946             elsif Nkind (Parent (N)) = N_Package_Body
5947               and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
5948             then
5949
5950                declare
5951                   Enclosing : constant Entity_Id :=
5952                                 Corresponding_Spec (Parent (N));
5953
5954                begin
5955                   Insert_After_Last_Decl (N, F_Node);
5956                   Ensure_Freeze_Node (Enclosing);
5957
5958                   if not Is_List_Member (Freeze_Node (Enclosing)) then
5959                      Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing));
5960                   end if;
5961                end;
5962
5963             else
5964                Insert_After_Last_Decl (N, F_Node);
5965             end if;
5966
5967          else
5968             Insert_After_Last_Decl (N, F_Node);
5969          end if;
5970       end if;
5971
5972       Set_Is_Frozen (Act_Id);
5973       Insert_Before (N, Act_Body);
5974       Mark_Rewrite_Insertion (Act_Body);
5975    end Install_Body;
5976
5977    --------------------
5978    -- Install_Parent --
5979    --------------------
5980
5981    procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
5982       Ancestors : constant Elist_Id  := New_Elmt_List;
5983       S         : constant Entity_Id := Current_Scope;
5984       Inst_Par  : Entity_Id;
5985       First_Par : Entity_Id;
5986       Inst_Node : Node_Id;
5987       Gen_Par   : Entity_Id;
5988       First_Gen : Entity_Id;
5989       Elmt      : Elmt_Id;
5990
5991       procedure Install_Formal_Packages (Par : Entity_Id);
5992       --  If any of the formals of the parent are formal packages with box,
5993       --  their formal parts are visible in the parent and thus in the child
5994       --  unit as well. Analogous to what is done in Check_Generic_Actuals
5995       --  for the unit itself.
5996
5997       procedure Install_Noninstance_Specs (Par : Entity_Id);
5998       --  Install the scopes of noninstance parent units ending with Par.
5999
6000       procedure Install_Spec (Par : Entity_Id);
6001       --  The child unit is within the declarative part of the parent, so
6002       --  the declarations within the parent are immediately visible.
6003
6004       -----------------------------
6005       -- Install_Formal_Packages --
6006       -----------------------------
6007
6008       procedure Install_Formal_Packages (Par : Entity_Id) is
6009          E : Entity_Id;
6010
6011       begin
6012          E := First_Entity (Par);
6013
6014          while Present (E) loop
6015
6016             if Ekind (E) = E_Package
6017               and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
6018             then
6019                --  If this is the renaming for the parent instance, done.
6020
6021                if Renamed_Object (E) = Par then
6022                   exit;
6023
6024                --  The visibility of a formal of an enclosing generic is
6025                --  already correct.
6026
6027                elsif Denotes_Formal_Package (E) then
6028                   null;
6029
6030                elsif Present (Associated_Formal_Package (E))
6031                  and then Box_Present (Parent (Associated_Formal_Package (E)))
6032                then
6033                   Check_Generic_Actuals (Renamed_Object (E), True);
6034                   Set_Is_Hidden (E, False);
6035                end if;
6036             end if;
6037
6038             Next_Entity (E);
6039          end loop;
6040       end Install_Formal_Packages;
6041
6042       -------------------------------
6043       -- Install_Noninstance_Specs --
6044       -------------------------------
6045
6046       procedure Install_Noninstance_Specs (Par : Entity_Id) is
6047       begin
6048          if Present (Par)
6049            and then Par /= Standard_Standard
6050            and then not In_Open_Scopes (Par)
6051          then
6052             Install_Noninstance_Specs (Scope (Par));
6053             Install_Spec (Par);
6054          end if;
6055       end Install_Noninstance_Specs;
6056
6057       ------------------
6058       -- Install_Spec --
6059       ------------------
6060
6061       procedure Install_Spec (Par : Entity_Id) is
6062          Spec : constant Node_Id :=
6063                   Specification (Unit_Declaration_Node (Par));
6064
6065       begin
6066          New_Scope (Par);
6067          Set_Is_Immediately_Visible   (Par);
6068          Install_Visible_Declarations (Par);
6069          Install_Private_Declarations (Par);
6070          Set_Use (Visible_Declarations (Spec));
6071          Set_Use (Private_Declarations (Spec));
6072       end Install_Spec;
6073
6074    --  Start of processing for Install_Parent
6075
6076    begin
6077       --  We need to install the parent instance to compile the instantiation
6078       --  of the child, but the child instance must appear in the current
6079       --  scope. Given that we cannot place the parent above the current
6080       --  scope in the scope stack, we duplicate the current scope and unstack
6081       --  both after the instantiation is complete.
6082
6083       --  If the parent is itself the instantiation of a child unit, we must
6084       --  also stack the instantiation of its parent, and so on. Each such
6085       --  ancestor is the prefix of the name in a prior instantiation.
6086
6087       --  If this is a nested instance, the parent unit itself resolves to
6088       --  a renaming of the parent instance, whose declaration we need.
6089
6090       --  Finally, the parent may be a generic (not an instance) when the
6091       --  child unit appears as a formal package.
6092
6093       Inst_Par := P;
6094
6095       if Present (Renamed_Entity (Inst_Par)) then
6096          Inst_Par := Renamed_Entity (Inst_Par);
6097       end if;
6098
6099       First_Par := Inst_Par;
6100
6101       Gen_Par :=
6102         Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
6103
6104       First_Gen := Gen_Par;
6105
6106       while Present (Gen_Par)
6107         and then Is_Child_Unit (Gen_Par)
6108       loop
6109          --  Load grandparent instance as well
6110
6111          Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
6112
6113          if Nkind (Name (Inst_Node)) = N_Expanded_Name then
6114             Inst_Par := Entity (Prefix (Name (Inst_Node)));
6115
6116             if Present (Renamed_Entity (Inst_Par)) then
6117                Inst_Par := Renamed_Entity (Inst_Par);
6118             end if;
6119
6120             Gen_Par :=
6121               Generic_Parent
6122                 (Specification (Unit_Declaration_Node (Inst_Par)));
6123
6124             if Present (Gen_Par) then
6125                Prepend_Elmt (Inst_Par, Ancestors);
6126
6127             else
6128                --  Parent is not the name of an instantiation
6129
6130                Install_Noninstance_Specs (Inst_Par);
6131
6132                exit;
6133             end if;
6134
6135          else
6136             --  Previous error
6137
6138             exit;
6139          end if;
6140       end loop;
6141
6142       if Present (First_Gen) then
6143          Append_Elmt (First_Par, Ancestors);
6144
6145       else
6146          Install_Noninstance_Specs (First_Par);
6147       end if;
6148
6149       if not Is_Empty_Elmt_List (Ancestors) then
6150          Elmt := First_Elmt (Ancestors);
6151
6152          while Present (Elmt) loop
6153             Install_Spec (Node (Elmt));
6154             Install_Formal_Packages (Node (Elmt));
6155
6156             Next_Elmt (Elmt);
6157          end loop;
6158       end if;
6159
6160       if not In_Body then
6161          New_Scope (S);
6162       end if;
6163    end Install_Parent;
6164
6165    --------------------------------
6166    -- Instantiate_Formal_Package --
6167    --------------------------------
6168
6169    function Instantiate_Formal_Package
6170      (Formal          : Node_Id;
6171       Actual          : Node_Id;
6172       Analyzed_Formal : Node_Id)
6173       return            List_Id
6174    is
6175       Loc         : constant Source_Ptr := Sloc (Actual);
6176       Actual_Pack : Entity_Id;
6177       Formal_Pack : Entity_Id;
6178       Gen_Parent  : Entity_Id;
6179       Decls       : List_Id;
6180       Nod         : Node_Id;
6181       Parent_Spec : Node_Id;
6182
6183       procedure Find_Matching_Actual
6184        (F    : Node_Id;
6185         Act  : in out Entity_Id);
6186       --  We need to associate each formal entity in the formal package
6187       --  with the corresponding entity in the actual package. The actual
6188       --  package has been analyzed and possibly expanded, and as a result
6189       --  there is no one-to-one correspondence between the two lists (for
6190       --  example, the actual may include subtypes, itypes, and inherited
6191       --  primitive operations, interspersed among the renaming declarations
6192       --  for the actuals) . We retrieve the corresponding actual by name
6193       --  because each actual has the same name as the formal, and they do
6194       --  appear in the same order.
6195
6196       function Formal_Entity
6197         (F       : Node_Id;
6198          Act_Ent : Entity_Id)
6199          return    Entity_Id;
6200       --  Returns the entity associated with the given formal F. In the
6201       --  case where F is a formal package, this function will iterate
6202       --  through all of F's formals and enter map associations from the
6203       --  actuals occurring in the formal package's corresponding actual
6204       --  package (obtained via Act_Ent) to the formal package's formal
6205       --  parameters. This function is called recursively for arbitrary
6206       --  levels of formal packages.
6207
6208       function Is_Instance_Of
6209         (Act_Spec : Entity_Id;
6210          Gen_Anc  : Entity_Id)
6211          return     Boolean;
6212       --  The actual can be an instantiation of a generic within another
6213       --  instance, in which case there is no direct link from it to the
6214       --  original generic ancestor. In that case, we recognize that the
6215       --  ultimate ancestor is the same by examining names and scopes.
6216
6217       procedure Map_Entities (Form : Entity_Id; Act : Entity_Id);
6218       --  Within the generic part, entities in the formal package are
6219       --  visible. To validate subsequent type declarations, indicate
6220       --  the correspondence betwen the entities in the analyzed formal,
6221       --  and the entities in  the actual package. There are three packages
6222       --  involved in the instantiation of a formal package: the parent
6223       --  generic P1 which appears in the generic declaration, the fake
6224       --  instantiation P2 which appears in the analyzed generic, and whose
6225       --  visible entities may be used in subsequent formals, and the actual
6226       --  P3 in the instance. To validate subsequent formals, me indicate
6227       --  that the entities in P2 are mapped into those of P3. The mapping of
6228       --  entities has to be done recursively for nested packages.
6229
6230       --------------------------
6231       -- Find_Matching_Actual --
6232       --------------------------
6233
6234       procedure Find_Matching_Actual
6235         (F   : Node_Id;
6236          Act : in out Entity_Id)
6237      is
6238          Formal_Ent : Entity_Id;
6239
6240       begin
6241          case Nkind (Original_Node (F)) is
6242             when N_Formal_Object_Declaration |
6243                  N_Formal_Type_Declaration   =>
6244                Formal_Ent := Defining_Identifier (F);
6245
6246                while Chars (Act) /= Chars (Formal_Ent) loop
6247                   Next_Entity (Act);
6248                end loop;
6249
6250             when N_Formal_Subprogram_Declaration |
6251                  N_Formal_Package_Declaration    |
6252                  N_Package_Declaration           |
6253                  N_Generic_Package_Declaration   =>
6254                Formal_Ent := Defining_Entity (F);
6255
6256                while Chars (Act) /= Chars (Formal_Ent) loop
6257                   Next_Entity (Act);
6258                end loop;
6259
6260             when others =>
6261                raise Program_Error;
6262          end case;
6263       end Find_Matching_Actual;
6264
6265       -------------------
6266       -- Formal_Entity --
6267       -------------------
6268
6269       function Formal_Entity
6270         (F       : Node_Id;
6271          Act_Ent : Entity_Id)
6272          return    Entity_Id
6273       is
6274          Orig_Node : Node_Id := F;
6275          Act_Pkg   : Entity_Id;
6276
6277       begin
6278          case Nkind (Original_Node (F)) is
6279             when N_Formal_Object_Declaration     =>
6280                return Defining_Identifier (F);
6281
6282             when N_Formal_Type_Declaration       =>
6283                return Defining_Identifier (F);
6284
6285             when N_Formal_Subprogram_Declaration =>
6286                return Defining_Unit_Name (Specification (F));
6287
6288             when N_Package_Declaration           =>
6289                return Defining_Unit_Name (Specification (F));
6290
6291             when N_Formal_Package_Declaration |
6292                  N_Generic_Package_Declaration   =>
6293
6294                if Nkind (F) = N_Generic_Package_Declaration then
6295                   Orig_Node := Original_Node (F);
6296                end if;
6297
6298                Act_Pkg := Act_Ent;
6299
6300                --  Find matching actual package, skipping over itypes and
6301                --  other entities generated when analyzing the formal. We
6302                --  know that if the instantiation is legal then there is
6303                --  a matching package for the formal.
6304
6305                while Ekind (Act_Pkg) /= E_Package loop
6306                   Act_Pkg := Next_Entity (Act_Pkg);
6307                end loop;
6308
6309                declare
6310                   Actual_Ent  : Entity_Id := First_Entity (Act_Pkg);
6311                   Formal_Node : Node_Id;
6312                   Formal_Ent  : Entity_Id;
6313
6314                   Gen_Decl : constant Node_Id :=
6315                                Unit_Declaration_Node
6316                                  (Entity (Name (Orig_Node)));
6317
6318                   Formals : constant List_Id :=
6319                               Generic_Formal_Declarations (Gen_Decl);
6320
6321                begin
6322                   if Present (Formals) then
6323                      Formal_Node := First_Non_Pragma (Formals);
6324                   else
6325                      Formal_Node := Empty;
6326                   end if;
6327
6328                   while Present (Actual_Ent)
6329                     and then Present (Formal_Node)
6330                     and then Actual_Ent /= First_Private_Entity (Act_Ent)
6331                   loop
6332                      --  ???  Are the following calls also needed here:
6333                      --
6334                      --  Set_Is_Hidden (Actual_Ent, False);
6335                      --  Set_Is_Potentially_Use_Visible
6336                      --    (Actual_Ent, In_Use (Act_Ent));
6337
6338                      Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
6339                      if Present (Formal_Ent) then
6340                         Set_Instance_Of (Formal_Ent, Actual_Ent);
6341                      end if;
6342                      Next_Non_Pragma (Formal_Node);
6343
6344                      Next_Entity (Actual_Ent);
6345                   end loop;
6346                end;
6347
6348                return Defining_Identifier (Orig_Node);
6349
6350             when N_Use_Package_Clause =>
6351                return Empty;
6352
6353             when N_Use_Type_Clause =>
6354                return Empty;
6355
6356             --  We return Empty for all other encountered forms of
6357             --  declarations because there are some cases of nonformal
6358             --  sorts of declaration that can show up (e.g., when array
6359             --  formals are present). Since it's not clear what kinds
6360             --  can appear among the formals, we won't raise failure here.
6361
6362             when others =>
6363                return Empty;
6364
6365          end case;
6366       end Formal_Entity;
6367
6368       --------------------
6369       -- Is_Instance_Of --
6370       --------------------
6371
6372       function Is_Instance_Of
6373         (Act_Spec : Entity_Id;
6374          Gen_Anc  : Entity_Id)
6375          return     Boolean
6376       is
6377          Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
6378
6379       begin
6380          if No (Gen_Par) then
6381             return False;
6382
6383          --  Simplest case: the generic parent of the actual is the formal.
6384
6385          elsif Gen_Par = Gen_Anc then
6386             return True;
6387
6388          elsif Chars (Gen_Par) /= Chars (Gen_Anc) then
6389             return False;
6390
6391          --  The actual may be obtained through several instantiations. Its
6392          --  scope must itself be an instance of a generic declared in the
6393          --  same scope as the formal. Any other case is detected above.
6394
6395          elsif not Is_Generic_Instance (Scope (Gen_Par)) then
6396             return False;
6397
6398          else
6399             return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc);
6400          end if;
6401       end Is_Instance_Of;
6402
6403       ------------------
6404       -- Map_Entities --
6405       ------------------
6406
6407       procedure Map_Entities (Form : Entity_Id; Act : Entity_Id) is
6408          E1 : Entity_Id;
6409          E2 : Entity_Id;
6410
6411       begin
6412          Set_Instance_Of (Form, Act);
6413
6414          --  Traverse formal and actual package to map the corresponding
6415          --  entities. We skip over internal entities that may be generated
6416          --  during semantic analysis, and find the matching entities by
6417          --  name, given that they must appear in the same order.
6418
6419          E1 := First_Entity (Form);
6420          E2 := First_Entity (Act);
6421          while Present (E1)
6422            and then E1 /= First_Private_Entity (Form)
6423          loop
6424             if not Is_Internal (E1)
6425               and then not Is_Class_Wide_Type (E1)
6426               and then Present (Parent (E1))
6427             then
6428                while Present (E2)
6429                  and then Chars (E2) /= Chars (E1)
6430                loop
6431                   Next_Entity (E2);
6432                end loop;
6433
6434                if No (E2) then
6435                   exit;
6436                else
6437                   Set_Instance_Of (E1, E2);
6438
6439                   if Is_Type (E1)
6440                     and then Is_Tagged_Type (E2)
6441                   then
6442                      Set_Instance_Of
6443                        (Class_Wide_Type (E1), Class_Wide_Type (E2));
6444                   end if;
6445
6446                   if Ekind (E1) = E_Package
6447                     and then No (Renamed_Object (E1))
6448                   then
6449                      Map_Entities (E1, E2);
6450                   end if;
6451                end if;
6452             end if;
6453
6454             Next_Entity (E1);
6455          end loop;
6456       end Map_Entities;
6457
6458    --  Start of processing for Instantiate_Formal_Package
6459
6460    begin
6461       Analyze (Actual);
6462
6463       if not Is_Entity_Name (Actual)
6464         or else  Ekind (Entity (Actual)) /= E_Package
6465       then
6466          Error_Msg_N
6467            ("expect package instance to instantiate formal", Actual);
6468          Abandon_Instantiation (Actual);
6469          raise Program_Error;
6470
6471       else
6472          Actual_Pack := Entity (Actual);
6473          Set_Is_Instantiated (Actual_Pack);
6474
6475          --  The actual may be a renamed package, or an outer generic
6476          --  formal package whose instantiation is converted into a renaming.
6477
6478          if Present (Renamed_Object (Actual_Pack)) then
6479             Actual_Pack := Renamed_Object (Actual_Pack);
6480          end if;
6481
6482          if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then
6483             Gen_Parent  := Get_Instance_Of (Entity (Name (Analyzed_Formal)));
6484             Formal_Pack := Defining_Identifier (Analyzed_Formal);
6485          else
6486             Gen_Parent :=
6487               Generic_Parent (Specification (Analyzed_Formal));
6488             Formal_Pack :=
6489               Defining_Unit_Name (Specification (Analyzed_Formal));
6490          end if;
6491
6492          if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then
6493             Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack));
6494          else
6495             Parent_Spec := Parent (Actual_Pack);
6496          end if;
6497
6498          if Gen_Parent = Any_Id then
6499             Error_Msg_N
6500               ("previous error in declaration of formal package", Actual);
6501             Abandon_Instantiation (Actual);
6502
6503          elsif
6504            Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent))
6505          then
6506             null;
6507
6508          else
6509             Error_Msg_NE
6510               ("actual parameter must be instance of&", Actual, Gen_Parent);
6511             Abandon_Instantiation (Actual);
6512          end if;
6513
6514          Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack);
6515          Map_Entities (Formal_Pack, Actual_Pack);
6516
6517          Nod :=
6518            Make_Package_Renaming_Declaration (Loc,
6519              Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
6520              Name               => New_Reference_To (Actual_Pack, Loc));
6521
6522          Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
6523            Defining_Identifier (Formal));
6524          Decls := New_List (Nod);
6525
6526          --  If the formal F has a box, then the generic declarations are
6527          --  visible in the generic G. In an instance of G, the corresponding
6528          --  entities in the actual for F (which are the actuals for the
6529          --  instantiation of the generic that F denotes) must also be made
6530          --  visible for analysis of the current instance. On exit from the
6531          --  current instance, those entities are made private again. If the
6532          --  actual is currently in use, these entities are also use-visible.
6533
6534          --  The loop through the actual entities also steps through the
6535          --  formal entities and enters associations from formals to
6536          --  actuals into the renaming map. This is necessary to properly
6537          --  handle checking of actual parameter associations for later
6538          --  formals that depend on actuals declared in the formal package.
6539
6540          if Box_Present (Formal) then
6541             declare
6542                Gen_Decl    : constant Node_Id :=
6543                                Unit_Declaration_Node (Gen_Parent);
6544                Formals     : constant List_Id :=
6545                                Generic_Formal_Declarations (Gen_Decl);
6546                Actual_Ent  : Entity_Id;
6547                Formal_Node : Node_Id;
6548                Formal_Ent  : Entity_Id;
6549
6550             begin
6551                if Present (Formals) then
6552                   Formal_Node := First_Non_Pragma (Formals);
6553                else
6554                   Formal_Node := Empty;
6555                end if;
6556
6557                Actual_Ent := First_Entity (Actual_Pack);
6558
6559                while Present (Actual_Ent)
6560                  and then Actual_Ent /= First_Private_Entity (Actual_Pack)
6561                loop
6562                   Set_Is_Hidden (Actual_Ent, False);
6563                   Set_Is_Potentially_Use_Visible
6564                     (Actual_Ent, In_Use (Actual_Pack));
6565
6566                   if Present (Formal_Node) then
6567                      Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
6568
6569                      if Present (Formal_Ent) then
6570                         Find_Matching_Actual (Formal_Node, Actual_Ent);
6571                         Set_Instance_Of (Formal_Ent, Actual_Ent);
6572                      end if;
6573
6574                      Next_Non_Pragma (Formal_Node);
6575
6576                   else
6577                      --  No further formals to match, but the generic
6578                      --  part may contain inherited operation that are
6579                      --  not hidden in the enclosing instance.
6580
6581                      Next_Entity (Actual_Ent);
6582                   end if;
6583
6584                end loop;
6585             end;
6586
6587          --  If the formal is not declared with a box, reanalyze it as
6588          --  an instantiation, to verify the matching rules of 12.7. The
6589          --  actual checks are performed after the generic associations
6590          --  been analyzed.
6591
6592          else
6593             declare
6594                I_Pack : constant Entity_Id :=
6595                           Make_Defining_Identifier (Sloc (Actual),
6596                             Chars => New_Internal_Name  ('P'));
6597
6598             begin
6599                Set_Is_Internal (I_Pack);
6600
6601                Append_To (Decls,
6602                  Make_Package_Instantiation (Sloc (Actual),
6603                    Defining_Unit_Name => I_Pack,
6604                    Name => New_Occurrence_Of (Gen_Parent, Sloc (Actual)),
6605                    Generic_Associations =>
6606                      Generic_Associations (Formal)));
6607             end;
6608          end if;
6609
6610          return Decls;
6611       end if;
6612    end Instantiate_Formal_Package;
6613
6614    -----------------------------------
6615    -- Instantiate_Formal_Subprogram --
6616    -----------------------------------
6617
6618    function Instantiate_Formal_Subprogram
6619      (Formal          : Node_Id;
6620       Actual          : Node_Id;
6621       Analyzed_Formal : Node_Id)
6622       return            Node_Id
6623    is
6624       Loc        : Source_Ptr := Sloc (Instantiation_Node);
6625       Formal_Sub : constant Entity_Id :=
6626                      Defining_Unit_Name (Specification (Formal));
6627       Analyzed_S : constant Entity_Id :=
6628                      Defining_Unit_Name (Specification (Analyzed_Formal));
6629       Decl_Node  : Node_Id;
6630       Nam        : Node_Id;
6631       New_Spec   : Node_Id;
6632
6633       function From_Parent_Scope (Subp : Entity_Id) return Boolean;
6634       --  If the generic is a child unit, the parent has been installed
6635       --  on the scope stack, but a default subprogram cannot resolve to
6636       --  something on the parent because that parent is not really part
6637       --  of the visible context (it is there to resolve explicit local
6638       --  entities). If the default has resolved in this way, we remove
6639       --  the entity from immediate visibility and analyze the node again
6640       --  to emit an error message or find another visible candidate.
6641
6642       procedure Valid_Actual_Subprogram (Act : Node_Id);
6643       --  Perform legality check and raise exception on failure.
6644
6645       -----------------------
6646       -- From_Parent_Scope --
6647       -----------------------
6648
6649       function From_Parent_Scope (Subp : Entity_Id) return Boolean is
6650          Gen_Scope : Node_Id := Scope (Analyzed_S);
6651
6652       begin
6653          while Present (Gen_Scope)
6654            and then  Is_Child_Unit (Gen_Scope)
6655          loop
6656             if Scope (Subp) = Scope (Gen_Scope) then
6657                return True;
6658             end if;
6659
6660             Gen_Scope := Scope (Gen_Scope);
6661          end loop;
6662
6663          return False;
6664       end From_Parent_Scope;
6665
6666       -----------------------------
6667       -- Valid_Actual_Subprogram --
6668       -----------------------------
6669
6670       procedure Valid_Actual_Subprogram (Act : Node_Id) is
6671          Act_E : Entity_Id := Empty;
6672
6673       begin
6674          if Is_Entity_Name (Act) then
6675             Act_E := Entity (Act);
6676          elsif Nkind (Act) = N_Selected_Component
6677            and then Is_Entity_Name (Selector_Name (Act))
6678          then
6679             Act_E := Entity (Selector_Name (Act));
6680          end if;
6681
6682          if (Present (Act_E) and then Is_Overloadable (Act_E))
6683            or else Nkind (Act) = N_Attribute_Reference
6684            or else Nkind (Act) = N_Indexed_Component
6685            or else Nkind (Act) = N_Character_Literal
6686            or else Nkind (Act) = N_Explicit_Dereference
6687          then
6688             return;
6689          end if;
6690
6691          Error_Msg_NE
6692            ("expect subprogram or entry name in instantiation of&",
6693             Instantiation_Node, Formal_Sub);
6694          Abandon_Instantiation (Instantiation_Node);
6695
6696       end Valid_Actual_Subprogram;
6697
6698    --  Start of processing for Instantiate_Formal_Subprogram
6699
6700    begin
6701       New_Spec := New_Copy_Tree (Specification (Formal));
6702
6703       --  Create new entity for the actual (New_Copy_Tree does not).
6704
6705       Set_Defining_Unit_Name
6706         (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
6707
6708       --  Find entity of actual. If the actual is an attribute reference, it
6709       --  cannot be resolved here (its formal is missing) but is handled
6710       --  instead in Attribute_Renaming. If the actual is overloaded, it is
6711       --  fully resolved subsequently, when the renaming declaration for the
6712       --  formal is analyzed. If it is an explicit dereference, resolve the
6713       --  prefix but not the actual itself, to prevent interpretation as a
6714       --  call.
6715
6716       if Present (Actual) then
6717          Loc := Sloc (Actual);
6718          Set_Sloc (New_Spec, Loc);
6719
6720          if Nkind (Actual) = N_Operator_Symbol then
6721             Find_Direct_Name (Actual);
6722
6723          elsif Nkind (Actual) = N_Explicit_Dereference then
6724             Analyze (Prefix (Actual));
6725
6726          elsif Nkind (Actual) /= N_Attribute_Reference then
6727             Analyze (Actual);
6728          end if;
6729
6730          Valid_Actual_Subprogram (Actual);
6731          Nam := Actual;
6732
6733       elsif Present (Default_Name (Formal)) then
6734          if Nkind (Default_Name (Formal)) /= N_Attribute_Reference
6735            and then Nkind (Default_Name (Formal)) /= N_Selected_Component
6736            and then Nkind (Default_Name (Formal)) /= N_Indexed_Component
6737            and then Nkind (Default_Name (Formal)) /= N_Character_Literal
6738            and then Present (Entity (Default_Name (Formal)))
6739          then
6740             Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
6741          else
6742             Nam := New_Copy (Default_Name (Formal));
6743             Set_Sloc (Nam, Loc);
6744          end if;
6745
6746       elsif Box_Present (Formal) then
6747
6748          --  Actual is resolved at the point of instantiation. Create
6749          --  an identifier or operator with the same name as the formal.
6750
6751          if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then
6752             Nam := Make_Operator_Symbol (Loc,
6753               Chars =>  Chars (Formal_Sub),
6754               Strval => No_String);
6755          else
6756             Nam := Make_Identifier (Loc, Chars (Formal_Sub));
6757          end if;
6758
6759       else
6760          Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
6761          Error_Msg_NE
6762            ("missing actual&", Instantiation_Node, Formal_Sub);
6763          Error_Msg_NE
6764            ("\in instantiation of & declared#",
6765               Instantiation_Node, Scope (Analyzed_S));
6766          Abandon_Instantiation (Instantiation_Node);
6767       end if;
6768
6769       Decl_Node :=
6770         Make_Subprogram_Renaming_Declaration (Loc,
6771           Specification => New_Spec,
6772           Name          => Nam);
6773
6774       --  If we do not have an actual and the formal specified <> then
6775       --  set to get proper default.
6776
6777       if No (Actual) and then Box_Present (Formal) then
6778          Set_From_Default (Decl_Node);
6779       end if;
6780
6781       --  Gather possible interpretations for the actual before analyzing the
6782       --  instance. If overloaded, it will be resolved when analyzing the
6783       --  renaming declaration.
6784
6785       if Box_Present (Formal)
6786         and then No (Actual)
6787       then
6788          Analyze (Nam);
6789
6790          if Is_Child_Unit (Scope (Analyzed_S))
6791            and then Present (Entity (Nam))
6792          then
6793             if not Is_Overloaded (Nam) then
6794
6795                if From_Parent_Scope (Entity (Nam)) then
6796                   Set_Is_Immediately_Visible (Entity (Nam), False);
6797                   Set_Entity (Nam, Empty);
6798                   Set_Etype (Nam, Empty);
6799
6800                   Analyze (Nam);
6801
6802                   Set_Is_Immediately_Visible (Entity (Nam));
6803                end if;
6804
6805             else
6806                declare
6807                   I  : Interp_Index;
6808                   It : Interp;
6809
6810                begin
6811                   Get_First_Interp (Nam, I, It);
6812
6813                   while Present (It.Nam) loop
6814                      if From_Parent_Scope (It.Nam) then
6815                         Remove_Interp (I);
6816                      end if;
6817
6818                      Get_Next_Interp (I, It);
6819                   end loop;
6820                end;
6821             end if;
6822          end if;
6823       end if;
6824
6825       --  The generic instantiation freezes the actual. This can only be
6826       --  done once the actual is resolved, in the analysis of the renaming
6827       --  declaration. To indicate that must be done, we set the corresponding
6828       --  spec of the node to point to the formal subprogram entity.
6829
6830       Set_Corresponding_Spec (Decl_Node, Analyzed_S);
6831
6832       --  We cannot analyze the renaming declaration, and thus find the
6833       --  actual, until the all the actuals are assembled in the instance.
6834       --  For subsequent checks of other actuals, indicate the node that
6835       --  will hold the instance of this formal.
6836
6837       Set_Instance_Of (Analyzed_S, Nam);
6838
6839       if Nkind (Actual) = N_Selected_Component
6840         and then Is_Task_Type (Etype (Prefix (Actual)))
6841         and then not Is_Frozen (Etype (Prefix (Actual)))
6842       then
6843          --  The renaming declaration will create a body, which must appear
6844          --  outside of the instantiation, We move the renaming declaration
6845          --  out of the instance, and create an additional renaming inside,
6846          --  to prevent freezing anomalies.
6847
6848          declare
6849             Anon_Id : constant Entity_Id :=
6850                         Make_Defining_Identifier
6851                           (Loc, New_Internal_Name ('E'));
6852          begin
6853             Set_Defining_Unit_Name (New_Spec, Anon_Id);
6854             Insert_Before (Instantiation_Node, Decl_Node);
6855             Analyze (Decl_Node);
6856
6857             --  Now create renaming within the instance
6858
6859             Decl_Node :=
6860               Make_Subprogram_Renaming_Declaration (Loc,
6861                 Specification => New_Copy_Tree (New_Spec),
6862                 Name => New_Occurrence_Of (Anon_Id, Loc));
6863
6864             Set_Defining_Unit_Name (Specification (Decl_Node),
6865               Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
6866          end;
6867       end if;
6868
6869       return Decl_Node;
6870    end Instantiate_Formal_Subprogram;
6871
6872    ------------------------
6873    -- Instantiate_Object --
6874    ------------------------
6875
6876    function Instantiate_Object
6877      (Formal          : Node_Id;
6878       Actual          : Node_Id;
6879       Analyzed_Formal : Node_Id)
6880       return            List_Id
6881    is
6882       Formal_Id : constant Entity_Id  := Defining_Identifier (Formal);
6883       Type_Id   : constant Node_Id    := Subtype_Mark (Formal);
6884       Loc       : constant Source_Ptr := Sloc (Actual);
6885       Act_Assoc : constant Node_Id    := Parent (Actual);
6886       Orig_Ftyp : constant Entity_Id  :=
6887                     Etype (Defining_Identifier (Analyzed_Formal));
6888       List      : constant List_Id    := New_List;
6889       Ftyp      : Entity_Id;
6890       Decl_Node : Node_Id;
6891       Subt_Decl : Node_Id := Empty;
6892
6893    begin
6894       --  Sloc for error message on missing actual.
6895       Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal)));
6896
6897       if Get_Instance_Of (Formal_Id) /= Formal_Id then
6898          Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
6899       end if;
6900
6901       Set_Parent (List, Parent (Actual));
6902
6903       --  OUT present
6904
6905       if Out_Present (Formal) then
6906
6907          --  An IN OUT generic actual must be a name. The instantiation is
6908          --  a renaming declaration. The actual is the name being renamed.
6909          --  We use the actual directly, rather than a copy, because it is not
6910          --  used further in the list of actuals, and because a copy or a use
6911          --  of relocate_node is incorrect if the instance is nested within
6912          --  a generic. In order to simplify ASIS searches, the Generic_Parent
6913          --  field links the declaration to the generic association.
6914
6915          if No (Actual) then
6916             Error_Msg_NE
6917               ("missing actual&",
6918                Instantiation_Node, Formal_Id);
6919             Error_Msg_NE
6920               ("\in instantiation of & declared#",
6921                  Instantiation_Node,
6922                    Scope (Defining_Identifier (Analyzed_Formal)));
6923             Abandon_Instantiation (Instantiation_Node);
6924          end if;
6925
6926          Decl_Node :=
6927            Make_Object_Renaming_Declaration (Loc,
6928              Defining_Identifier => New_Copy (Formal_Id),
6929              Subtype_Mark        => New_Copy_Tree (Type_Id),
6930              Name                => Actual);
6931
6932          Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
6933
6934          --  The analysis of the actual may produce insert_action nodes, so
6935          --  the declaration must have a context in which to attach them.
6936
6937          Append (Decl_Node, List);
6938          Analyze (Actual);
6939
6940          --  This check is performed here because Analyze_Object_Renaming
6941          --  will not check it when Comes_From_Source is False. Note
6942          --  though that the check for the actual being the name of an
6943          --  object will be performed in Analyze_Object_Renaming.
6944
6945          if Is_Object_Reference (Actual)
6946            and then Is_Dependent_Component_Of_Mutable_Object (Actual)
6947          then
6948             Error_Msg_N
6949               ("illegal discriminant-dependent component for in out parameter",
6950                Actual);
6951          end if;
6952
6953          --  The actual has to be resolved in order to check that it is
6954          --  a variable (due to cases such as F(1), where F returns
6955          --  access to an array, and for overloaded prefixes).
6956
6957          Ftyp :=
6958            Get_Instance_Of (Etype (Defining_Identifier (Analyzed_Formal)));
6959
6960          if Is_Private_Type (Ftyp)
6961            and then not Is_Private_Type (Etype (Actual))
6962            and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual))
6963                       or else Base_Type (Etype (Actual)) = Ftyp)
6964          then
6965             --  If the actual has the type of the full view of the formal,
6966             --  or else a non-private subtype of the formal, then
6967             --  the visibility of the formal type has changed. Add to the
6968             --  actuals a subtype declaration that will force the exchange
6969             --  of views in the body of the instance as well.
6970
6971             Subt_Decl :=
6972               Make_Subtype_Declaration (Loc,
6973                  Defining_Identifier =>
6974                    Make_Defining_Identifier (Loc, New_Internal_Name ('P')),
6975                  Subtype_Indication  => New_Occurrence_Of (Ftyp, Loc));
6976
6977             Prepend (Subt_Decl, List);
6978
6979             Append_Elmt (Full_View (Ftyp), Exchanged_Views);
6980             Exchange_Declarations (Ftyp);
6981          end if;
6982
6983          Resolve (Actual, Ftyp);
6984
6985          if not Is_Variable (Actual) or else Paren_Count (Actual) > 0 then
6986             Error_Msg_NE
6987               ("actual for& must be a variable", Actual, Formal_Id);
6988
6989          elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
6990             Error_Msg_NE (
6991               "type of actual does not match type of&", Actual, Formal_Id);
6992
6993          end if;
6994
6995          Note_Possible_Modification (Actual);
6996
6997          --  Check for instantiation of atomic/volatile actual for
6998          --  non-atomic/volatile formal (RM C.6 (12)).
6999
7000          if Is_Atomic_Object (Actual)
7001            and then not Is_Atomic (Orig_Ftyp)
7002          then
7003             Error_Msg_N
7004               ("cannot instantiate non-atomic formal object " &
7005                "with atomic actual", Actual);
7006
7007          elsif Is_Volatile_Object (Actual)
7008            and then not Is_Volatile (Orig_Ftyp)
7009          then
7010             Error_Msg_N
7011               ("cannot instantiate non-volatile formal object " &
7012                "with volatile actual", Actual);
7013          end if;
7014
7015       --  OUT not present
7016
7017       else
7018          --  The instantiation of a generic formal in-parameter
7019          --  is a constant declaration. The actual is the expression for
7020          --  that declaration.
7021
7022          if Present (Actual) then
7023
7024             Decl_Node := Make_Object_Declaration (Loc,
7025               Defining_Identifier => New_Copy (Formal_Id),
7026               Constant_Present => True,
7027               Object_Definition => New_Copy_Tree (Type_Id),
7028               Expression => Actual);
7029
7030             Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
7031
7032             --  A generic formal object of a tagged type is defined
7033             --  to be aliased so the new constant must also be treated
7034             --  as aliased.
7035
7036             if Is_Tagged_Type
7037                  (Etype (Defining_Identifier (Analyzed_Formal)))
7038             then
7039                Set_Aliased_Present (Decl_Node);
7040             end if;
7041
7042             Append (Decl_Node, List);
7043
7044             --  No need to repeat (pre-)analysis of some expression nodes
7045             --  already handled in Pre_Analyze_Actuals.
7046
7047             if Nkind (Actual) /= N_Allocator then
7048                Analyze (Actual);
7049             end if;
7050
7051             declare
7052                Typ : constant Entity_Id :=
7053                        Get_Instance_Of
7054                          (Etype (Defining_Identifier (Analyzed_Formal)));
7055
7056             begin
7057                Freeze_Before (Instantiation_Node, Typ);
7058
7059                --  If the actual is an aggregate, perform name resolution
7060                --  on its components (the analysis of an aggregate does not
7061                --  do it) to capture local names that may be hidden if the
7062                --  generic is a child unit.
7063
7064                if Nkind (Actual) = N_Aggregate then
7065                      Pre_Analyze_And_Resolve (Actual, Typ);
7066                end if;
7067             end;
7068
7069          elsif Present (Expression (Formal)) then
7070
7071             --  Use default to construct declaration.
7072
7073             Decl_Node :=
7074               Make_Object_Declaration (Sloc (Formal),
7075                 Defining_Identifier => New_Copy (Formal_Id),
7076                 Constant_Present    => True,
7077                 Object_Definition   => New_Copy (Type_Id),
7078                 Expression          => New_Copy_Tree (Expression (Formal)));
7079
7080             Append (Decl_Node, List);
7081             Set_Analyzed (Expression (Decl_Node), False);
7082
7083          else
7084             Error_Msg_NE
7085               ("missing actual&",
7086                 Instantiation_Node, Formal_Id);
7087             Error_Msg_NE ("\in instantiation of & declared#",
7088               Instantiation_Node,
7089                 Scope (Defining_Identifier (Analyzed_Formal)));
7090
7091             if Is_Scalar_Type
7092                  (Etype (Defining_Identifier (Analyzed_Formal)))
7093             then
7094                --  Create dummy constant declaration so that instance can
7095                --  be analyzed, to minimize cascaded visibility errors.
7096
7097                Decl_Node :=
7098                  Make_Object_Declaration (Loc,
7099                    Defining_Identifier => New_Copy (Formal_Id),
7100                    Constant_Present    => True,
7101                    Object_Definition   => New_Copy (Type_Id),
7102                    Expression          =>
7103                       Make_Attribute_Reference (Sloc (Formal_Id),
7104                         Attribute_Name => Name_First,
7105                         Prefix         => New_Copy (Type_Id)));
7106
7107                Append (Decl_Node, List);
7108
7109             else
7110                Abandon_Instantiation (Instantiation_Node);
7111             end if;
7112          end if;
7113
7114       end if;
7115
7116       return List;
7117    end Instantiate_Object;
7118
7119    ------------------------------
7120    -- Instantiate_Package_Body --
7121    ------------------------------
7122
7123    procedure Instantiate_Package_Body
7124      (Body_Info    : Pending_Body_Info;
7125       Inlined_Body : Boolean := False)
7126    is
7127       Act_Decl    : constant Node_Id    := Body_Info.Act_Decl;
7128       Inst_Node   : constant Node_Id    := Body_Info.Inst_Node;
7129       Loc         : constant Source_Ptr := Sloc (Inst_Node);
7130
7131       Gen_Id      : constant Node_Id    := Name (Inst_Node);
7132       Gen_Unit    : constant Entity_Id  := Get_Generic_Entity (Inst_Node);
7133       Gen_Decl    : constant Node_Id    := Unit_Declaration_Node (Gen_Unit);
7134       Act_Spec    : constant Node_Id    := Specification (Act_Decl);
7135       Act_Decl_Id : constant Entity_Id  := Defining_Entity (Act_Spec);
7136
7137       Act_Body_Name : Node_Id;
7138       Gen_Body      : Node_Id;
7139       Gen_Body_Id   : Node_Id;
7140       Act_Body      : Node_Id;
7141       Act_Body_Id   : Entity_Id;
7142
7143       Parent_Installed : Boolean := False;
7144       Save_Style_Check : constant Boolean := Style_Check;
7145
7146    begin
7147       Gen_Body_Id := Corresponding_Body (Gen_Decl);
7148
7149       --  The instance body may already have been processed, as the parent
7150       --  of another instance that is inlined. (Load_Parent_Of_Generic).
7151
7152       if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then
7153          return;
7154       end if;
7155
7156       Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
7157
7158       if No (Gen_Body_Id) then
7159          Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl));
7160          Gen_Body_Id := Corresponding_Body (Gen_Decl);
7161       end if;
7162
7163       --  Establish global variable for sloc adjustment and for error
7164       --  recovery.
7165
7166       Instantiation_Node := Inst_Node;
7167
7168       if Present (Gen_Body_Id) then
7169          Save_Env (Gen_Unit, Act_Decl_Id);
7170          Style_Check := False;
7171          Current_Sem_Unit := Body_Info.Current_Sem_Unit;
7172
7173          Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
7174
7175          Create_Instantiation_Source
7176           (Inst_Node, Gen_Body_Id, False, S_Adjustment);
7177
7178          Act_Body :=
7179            Copy_Generic_Node
7180              (Original_Node (Gen_Body), Empty, Instantiating => True);
7181
7182          --  Build new name (possibly qualified) for body declaration
7183
7184          Act_Body_Id := New_Copy (Act_Decl_Id);
7185
7186          --  Some attributes of the spec entity are not inherited by the
7187          --  body entity.
7188
7189          Set_Handler_Records (Act_Body_Id, No_List);
7190
7191          if Nkind (Defining_Unit_Name (Act_Spec)) =
7192                                            N_Defining_Program_Unit_Name
7193          then
7194             Act_Body_Name :=
7195               Make_Defining_Program_Unit_Name (Loc,
7196                 Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
7197                 Defining_Identifier => Act_Body_Id);
7198          else
7199             Act_Body_Name :=  Act_Body_Id;
7200          end if;
7201
7202          Set_Defining_Unit_Name (Act_Body, Act_Body_Name);
7203
7204          Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
7205          Check_Generic_Actuals (Act_Decl_Id, False);
7206
7207          --  If it is a child unit, make the parent instance (which is an
7208          --  instance of the parent of the generic) visible. The parent
7209          --  instance is the prefix of the name of the generic unit.
7210
7211          if Ekind (Scope (Gen_Unit)) = E_Generic_Package
7212            and then Nkind (Gen_Id) = N_Expanded_Name
7213          then
7214             Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
7215             Parent_Installed := True;
7216
7217          elsif Is_Child_Unit (Gen_Unit) then
7218             Install_Parent (Scope (Gen_Unit), In_Body => True);
7219             Parent_Installed := True;
7220          end if;
7221
7222          --  If the instantiation is a library unit, and this is the main
7223          --  unit, then build the resulting compilation unit nodes for the
7224          --  instance. If this is a compilation unit but it is not the main
7225          --  unit, then it is the body of a unit in the context, that is being
7226          --  compiled because it is encloses some inlined unit or another
7227          --  generic unit being instantiated. In that case, this body is not
7228          --  part of the current compilation, and is not attached to the tree,
7229          --  but its parent must be set for analysis.
7230
7231          if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
7232
7233             --  Replace instance node with body of instance, and create
7234             --  new node for corresponding instance declaration.
7235
7236             Build_Instance_Compilation_Unit_Nodes
7237               (Inst_Node, Act_Body, Act_Decl);
7238             Analyze (Inst_Node);
7239
7240             if Parent (Inst_Node) = Cunit (Main_Unit) then
7241
7242                --  If the instance is a child unit itself, then set the
7243                --  scope of the expanded body to be the parent of the
7244                --  instantiation (ensuring that the fully qualified name
7245                --  will be generated for the elaboration subprogram).
7246
7247                if Nkind (Defining_Unit_Name (Act_Spec)) =
7248                                               N_Defining_Program_Unit_Name
7249                then
7250                   Set_Scope
7251                     (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
7252                end if;
7253             end if;
7254
7255          --  Case where instantiation is not a library unit
7256
7257          else
7258             --  If this is an early instantiation, i.e. appears textually
7259             --  before the corresponding body and must be elaborated first,
7260             --  indicate that the body instance is to be delayed.
7261
7262             Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl);
7263
7264             --  Now analyze the body. We turn off all checks if this is
7265             --  an internal unit, since there is no reason to have checks
7266             --  on for any predefined run-time library code. All such
7267             --  code is designed to be compiled with checks off.
7268
7269             --  Note that we do NOT apply this criterion to children of
7270             --  GNAT (or on VMS, children of DEC). The latter units must
7271             --  suppress checks explicitly if this is needed.
7272
7273             if Is_Predefined_File_Name
7274                  (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
7275             then
7276                Analyze (Act_Body, Suppress => All_Checks);
7277             else
7278                Analyze (Act_Body);
7279             end if;
7280          end if;
7281
7282          if not Generic_Separately_Compiled (Gen_Unit) then
7283             Inherit_Context (Gen_Body, Inst_Node);
7284          end if;
7285
7286          --  Remove the parent instances if they have been placed on the
7287          --  scope stack to compile the body.
7288
7289          if Parent_Installed then
7290             Remove_Parent (In_Body => True);
7291          end if;
7292
7293          Restore_Private_Views (Act_Decl_Id);
7294
7295          --  Remove the current unit from visibility if this is an instance
7296          --  that is not elaborated on the fly for inlining purposes.
7297
7298          if not Inlined_Body then
7299             Set_Is_Immediately_Visible (Act_Decl_Id, False);
7300          end if;
7301
7302          Restore_Env;
7303          Style_Check := Save_Style_Check;
7304
7305       --  If we have no body, and the unit requires a body, then complain.
7306       --  This complaint is suppressed if we have detected other errors
7307       --  (since a common reason for missing the body is that it had errors).
7308
7309       elsif Unit_Requires_Body (Gen_Unit) then
7310          if Serious_Errors_Detected = 0 then
7311             Error_Msg_NE
7312               ("cannot find body of generic package &", Inst_Node, Gen_Unit);
7313
7314          --  Don't attempt to perform any cleanup actions if some other
7315          --  error was aready detected, since this can cause blowups.
7316
7317          else
7318             return;
7319          end if;
7320
7321       --  Case of package that does not need a body
7322
7323       else
7324          --  If the instantiation of the declaration is a library unit,
7325          --  rewrite the original package instantiation as a package
7326          --  declaration in the compilation unit node.
7327
7328          if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
7329             Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
7330             Rewrite (Inst_Node, Act_Decl);
7331
7332             --  Generate elaboration entity, in case spec has elaboration
7333             --  code. This cannot be done when the instance is analyzed,
7334             --  because it is not known yet whether the body exists.
7335
7336             Set_Elaboration_Entity_Required (Act_Decl_Id, False);
7337             Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id);
7338
7339          --  If the instantiation is not a library unit, then append the
7340          --  declaration to the list of implicitly generated entities.
7341          --  unless it is already a list member which means that it was
7342          --  already processed
7343
7344          elsif not Is_List_Member (Act_Decl) then
7345             Mark_Rewrite_Insertion (Act_Decl);
7346             Insert_Before (Inst_Node, Act_Decl);
7347          end if;
7348       end if;
7349
7350       Expander_Mode_Restore;
7351    end Instantiate_Package_Body;
7352
7353    ---------------------------------
7354    -- Instantiate_Subprogram_Body --
7355    ---------------------------------
7356
7357    procedure Instantiate_Subprogram_Body
7358      (Body_Info : Pending_Body_Info)
7359    is
7360       Act_Decl      : constant Node_Id    := Body_Info.Act_Decl;
7361       Inst_Node     : constant Node_Id    := Body_Info.Inst_Node;
7362       Loc           : constant Source_Ptr := Sloc (Inst_Node);
7363       Gen_Id        : constant Node_Id   := Name (Inst_Node);
7364       Gen_Unit      : constant Entity_Id := Get_Generic_Entity (Inst_Node);
7365       Gen_Decl      : constant Node_Id   := Unit_Declaration_Node (Gen_Unit);
7366       Anon_Id       : constant Entity_Id :=
7367                         Defining_Unit_Name (Specification (Act_Decl));
7368       Pack_Id       : constant Entity_Id :=
7369                         Defining_Unit_Name (Parent (Act_Decl));
7370       Decls         : List_Id;
7371       Gen_Body      : Node_Id;
7372       Gen_Body_Id   : Node_Id;
7373       Act_Body      : Node_Id;
7374       Act_Body_Id   : Entity_Id;
7375       Pack_Body     : Node_Id;
7376       Prev_Formal   : Entity_Id;
7377       Ret_Expr      : Node_Id;
7378       Unit_Renaming : Node_Id;
7379
7380       Parent_Installed : Boolean := False;
7381       Save_Style_Check : constant Boolean := Style_Check;
7382
7383    begin
7384       Gen_Body_Id := Corresponding_Body (Gen_Decl);
7385
7386       Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
7387
7388       if No (Gen_Body_Id) then
7389          Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl));
7390          Gen_Body_Id := Corresponding_Body (Gen_Decl);
7391       end if;
7392
7393       Instantiation_Node := Inst_Node;
7394
7395       if Present (Gen_Body_Id) then
7396          Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
7397
7398          if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
7399
7400             --  Either body is not present, or context is non-expanding, as
7401             --  when compiling a subunit. Mark the instance as completed, and
7402             --  diagnose a missing body when needed.
7403
7404             if Expander_Active
7405               and then Operating_Mode = Generate_Code
7406             then
7407                Error_Msg_N
7408                  ("missing proper body for instantiation", Gen_Body);
7409             end if;
7410
7411             Set_Has_Completion (Anon_Id);
7412             return;
7413          end if;
7414
7415          Save_Env (Gen_Unit, Anon_Id);
7416          Style_Check := False;
7417          Current_Sem_Unit := Body_Info.Current_Sem_Unit;
7418          Create_Instantiation_Source
7419            (Inst_Node,
7420             Gen_Body_Id,
7421             False,
7422             S_Adjustment);
7423
7424          Act_Body :=
7425            Copy_Generic_Node
7426              (Original_Node (Gen_Body), Empty, Instantiating => True);
7427          Act_Body_Id := Defining_Entity (Act_Body);
7428          Set_Chars (Act_Body_Id, Chars (Anon_Id));
7429          Set_Sloc (Act_Body_Id, Sloc (Defining_Entity (Inst_Node)));
7430          Set_Corresponding_Spec (Act_Body, Anon_Id);
7431          Set_Has_Completion (Anon_Id);
7432          Check_Generic_Actuals (Pack_Id, False);
7433
7434          --  If it is a child unit, make the parent instance (which is an
7435          --  instance of the parent of the generic) visible. The parent
7436          --  instance is the prefix of the name of the generic unit.
7437
7438          if Ekind (Scope (Gen_Unit)) = E_Generic_Package
7439            and then Nkind (Gen_Id) = N_Expanded_Name
7440          then
7441             Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
7442             Parent_Installed := True;
7443
7444          elsif Is_Child_Unit (Gen_Unit) then
7445             Install_Parent (Scope (Gen_Unit), In_Body => True);
7446             Parent_Installed := True;
7447          end if;
7448
7449          --  Inside its body, a reference to the generic unit is a reference
7450          --  to the instance. The corresponding renaming is the first
7451          --  declaration in the body.
7452
7453          Unit_Renaming :=
7454            Make_Subprogram_Renaming_Declaration (Loc,
7455              Specification =>
7456                Copy_Generic_Node (
7457                  Specification (Original_Node (Gen_Body)),
7458                  Empty,
7459                  Instantiating => True),
7460              Name => New_Occurrence_Of (Anon_Id, Loc));
7461
7462          --  If there is a formal subprogram with the same name as the
7463          --  unit itself, do not add this renaming declaration. This is
7464          --  a temporary fix for one ACVC test. ???
7465
7466          Prev_Formal := First_Entity (Pack_Id);
7467          while Present (Prev_Formal) loop
7468             if Chars (Prev_Formal) = Chars (Gen_Unit)
7469               and then Is_Overloadable (Prev_Formal)
7470             then
7471                exit;
7472             end if;
7473
7474             Next_Entity (Prev_Formal);
7475          end loop;
7476
7477          if Present (Prev_Formal) then
7478             Decls :=  New_List (Act_Body);
7479          else
7480             Decls :=  New_List (Unit_Renaming, Act_Body);
7481          end if;
7482
7483          --  The subprogram body is placed in the body of a dummy package
7484          --  body, whose spec contains the subprogram declaration as well
7485          --  as the renaming declarations for the generic parameters.
7486
7487          Pack_Body := Make_Package_Body (Loc,
7488            Defining_Unit_Name => New_Copy (Pack_Id),
7489            Declarations       => Decls);
7490
7491          Set_Corresponding_Spec (Pack_Body, Pack_Id);
7492
7493          --  If the instantiation is a library unit, then build resulting
7494          --  compilation unit nodes for the instance. The declaration of
7495          --  the enclosing package is the grandparent of the subprogram
7496          --  declaration. First replace the instantiation node as the unit
7497          --  of the corresponding compilation.
7498
7499          if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
7500             if Parent (Inst_Node) = Cunit (Main_Unit) then
7501                Set_Unit (Parent (Inst_Node), Inst_Node);
7502                Build_Instance_Compilation_Unit_Nodes
7503                  (Inst_Node, Pack_Body, Parent (Parent (Act_Decl)));
7504                Analyze (Inst_Node);
7505             else
7506                Set_Parent (Pack_Body, Parent (Inst_Node));
7507                Analyze (Pack_Body);
7508             end if;
7509
7510          else
7511             Insert_Before (Inst_Node, Pack_Body);
7512             Mark_Rewrite_Insertion (Pack_Body);
7513             Analyze (Pack_Body);
7514
7515             if Expander_Active then
7516                Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id);
7517             end if;
7518          end if;
7519
7520          if not Generic_Separately_Compiled (Gen_Unit) then
7521             Inherit_Context (Gen_Body, Inst_Node);
7522          end if;
7523
7524          Restore_Private_Views (Pack_Id, False);
7525
7526          if Parent_Installed then
7527             Remove_Parent (In_Body => True);
7528          end if;
7529
7530          Restore_Env;
7531          Style_Check := Save_Style_Check;
7532
7533       --  Body not found. Error was emitted already. If there were no
7534       --  previous errors, this may be an instance whose scope is a premature
7535       --  instance. In that case we must insure that the (legal) program does
7536       --  raise program error if executed. We generate a subprogram body for
7537       --  this purpose. See DEC ac30vso.
7538
7539       elsif Serious_Errors_Detected = 0
7540         and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
7541       then
7542          if Ekind (Anon_Id) = E_Procedure then
7543             Act_Body :=
7544               Make_Subprogram_Body (Loc,
7545                  Specification              =>
7546                    Make_Procedure_Specification (Loc,
7547                      Defining_Unit_Name         => New_Copy (Anon_Id),
7548                        Parameter_Specifications =>
7549                        New_Copy_List
7550                          (Parameter_Specifications (Parent (Anon_Id)))),
7551
7552                  Declarations               => Empty_List,
7553                  Handled_Statement_Sequence =>
7554                    Make_Handled_Sequence_Of_Statements (Loc,
7555                      Statements =>
7556                        New_List (
7557                          Make_Raise_Program_Error (Loc,
7558                            Reason =>
7559                              PE_Access_Before_Elaboration))));
7560
7561          else
7562             Ret_Expr :=
7563               Make_Raise_Program_Error (Loc,
7564                 Reason => PE_Access_Before_Elaboration);
7565
7566             Set_Etype (Ret_Expr, (Etype (Anon_Id)));
7567             Set_Analyzed (Ret_Expr);
7568
7569             Act_Body :=
7570               Make_Subprogram_Body (Loc,
7571                 Specification =>
7572                   Make_Function_Specification (Loc,
7573                      Defining_Unit_Name         => New_Copy (Anon_Id),
7574                        Parameter_Specifications =>
7575                        New_Copy_List
7576                          (Parameter_Specifications (Parent (Anon_Id))),
7577                      Subtype_Mark =>
7578                        New_Occurrence_Of (Etype (Anon_Id), Loc)),
7579
7580                   Declarations               => Empty_List,
7581                   Handled_Statement_Sequence =>
7582                     Make_Handled_Sequence_Of_Statements (Loc,
7583                       Statements =>
7584                         New_List (Make_Return_Statement (Loc, Ret_Expr))));
7585          end if;
7586
7587          Pack_Body := Make_Package_Body (Loc,
7588            Defining_Unit_Name => New_Copy (Pack_Id),
7589            Declarations       => New_List (Act_Body));
7590
7591          Insert_After (Inst_Node, Pack_Body);
7592          Set_Corresponding_Spec (Pack_Body, Pack_Id);
7593          Analyze (Pack_Body);
7594       end if;
7595
7596       Expander_Mode_Restore;
7597    end Instantiate_Subprogram_Body;
7598
7599    ----------------------
7600    -- Instantiate_Type --
7601    ----------------------
7602
7603    function Instantiate_Type
7604      (Formal          : Node_Id;
7605       Actual          : Node_Id;
7606       Analyzed_Formal : Node_Id;
7607       Actual_Decls    : List_Id)
7608       return            Node_Id
7609    is
7610       Loc       : constant Source_Ptr := Sloc (Actual);
7611       Gen_T     : constant Entity_Id  := Defining_Identifier (Formal);
7612       A_Gen_T   : constant Entity_Id  := Defining_Identifier (Analyzed_Formal);
7613       Ancestor  : Entity_Id := Empty;
7614       Def       : constant Node_Id    := Formal_Type_Definition (Formal);
7615       Act_T     : Entity_Id;
7616       Decl_Node : Node_Id;
7617
7618       procedure Validate_Array_Type_Instance;
7619       procedure Validate_Access_Subprogram_Instance;
7620       procedure Validate_Access_Type_Instance;
7621       procedure Validate_Derived_Type_Instance;
7622       procedure Validate_Private_Type_Instance;
7623       --  These procedures perform validation tests for the named case
7624
7625       function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
7626       --  Check that base types are the same and that the subtypes match
7627       --  statically. Used in several of the above.
7628
7629       --------------------
7630       -- Subtypes_Match --
7631       --------------------
7632
7633       function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is
7634          T : constant Entity_Id := Get_Instance_Of (Gen_T);
7635
7636       begin
7637          return (Base_Type (T) = Base_Type (Act_T)
7638 --  why is the and then commented out here???
7639 --                  and then Is_Constrained (T) = Is_Constrained (Act_T)
7640                   and then Subtypes_Statically_Match (T, Act_T))
7641
7642            or else (Is_Class_Wide_Type (Gen_T)
7643                      and then Is_Class_Wide_Type (Act_T)
7644                      and then
7645                        Subtypes_Match (
7646                          Get_Instance_Of (Root_Type (Gen_T)),
7647                          Root_Type (Act_T)));
7648       end Subtypes_Match;
7649
7650       -----------------------------------------
7651       -- Validate_Access_Subprogram_Instance --
7652       -----------------------------------------
7653
7654       procedure Validate_Access_Subprogram_Instance is
7655       begin
7656          if not Is_Access_Type (Act_T)
7657            or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type
7658          then
7659             Error_Msg_NE
7660               ("expect access type in instantiation of &", Actual, Gen_T);
7661             Abandon_Instantiation (Actual);
7662          end if;
7663
7664          Check_Mode_Conformant
7665            (Designated_Type (Act_T),
7666             Designated_Type (A_Gen_T),
7667             Actual,
7668             Get_Inst => True);
7669
7670          if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then
7671             if Ekind (A_Gen_T) = E_Access_Subprogram_Type then
7672                Error_Msg_NE
7673                  ("protected access type not allowed for formal &",
7674                   Actual, Gen_T);
7675             end if;
7676
7677          elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then
7678             Error_Msg_NE
7679               ("expect protected access type for formal &",
7680                Actual, Gen_T);
7681          end if;
7682       end Validate_Access_Subprogram_Instance;
7683
7684       -----------------------------------
7685       -- Validate_Access_Type_Instance --
7686       -----------------------------------
7687
7688       procedure Validate_Access_Type_Instance is
7689          Desig_Type : constant Entity_Id :=
7690                         Find_Actual_Type
7691                           (Designated_Type (A_Gen_T), Scope (A_Gen_T));
7692
7693       begin
7694          if not Is_Access_Type (Act_T) then
7695             Error_Msg_NE
7696               ("expect access type in instantiation of &", Actual, Gen_T);
7697             Abandon_Instantiation (Actual);
7698          end if;
7699
7700          if Is_Access_Constant (A_Gen_T) then
7701             if not Is_Access_Constant (Act_T) then
7702                Error_Msg_N
7703                  ("actual type must be access-to-constant type", Actual);
7704                Abandon_Instantiation (Actual);
7705             end if;
7706          else
7707             if Is_Access_Constant (Act_T) then
7708                Error_Msg_N
7709                  ("actual type must be access-to-variable type", Actual);
7710                Abandon_Instantiation (Actual);
7711
7712             elsif Ekind (A_Gen_T) = E_General_Access_Type
7713               and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
7714             then
7715                Error_Msg_N ("actual must be general access type!", Actual);
7716                Error_Msg_NE ("add ALL to }!", Actual, Act_T);
7717                Abandon_Instantiation (Actual);
7718             end if;
7719          end if;
7720
7721          --  The designated subtypes, that is to say the subtypes introduced
7722          --  by an access type declaration (and not by a subtype declaration)
7723          --  must match.
7724
7725          if not Subtypes_Match
7726            (Desig_Type, Designated_Type (Base_Type (Act_T)))
7727          then
7728             Error_Msg_NE
7729               ("designated type of actual does not match that of formal &",
7730                  Actual, Gen_T);
7731             Abandon_Instantiation (Actual);
7732
7733          elsif Is_Access_Type (Designated_Type (Act_T))
7734            and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
7735                       /=
7736                   Is_Constrained (Designated_Type (Desig_Type))
7737          then
7738             Error_Msg_NE
7739               ("designated type of actual does not match that of formal &",
7740                  Actual, Gen_T);
7741             Abandon_Instantiation (Actual);
7742          end if;
7743       end Validate_Access_Type_Instance;
7744
7745       ----------------------------------
7746       -- Validate_Array_Type_Instance --
7747       ----------------------------------
7748
7749       procedure Validate_Array_Type_Instance is
7750          I1 : Node_Id;
7751          I2 : Node_Id;
7752          T2 : Entity_Id;
7753
7754          function Formal_Dimensions return Int;
7755          --  Count number of dimensions in array type formal
7756
7757          function Formal_Dimensions return Int is
7758             Num   : Int := 0;
7759             Index : Node_Id;
7760
7761          begin
7762             if Nkind (Def) = N_Constrained_Array_Definition then
7763                Index := First (Discrete_Subtype_Definitions (Def));
7764             else
7765                Index := First (Subtype_Marks (Def));
7766             end if;
7767
7768             while Present (Index) loop
7769                Num := Num + 1;
7770                Next_Index (Index);
7771             end loop;
7772
7773             return Num;
7774          end Formal_Dimensions;
7775
7776       --  Start of processing for Validate_Array_Type_Instance
7777
7778       begin
7779          if not Is_Array_Type (Act_T) then
7780             Error_Msg_NE
7781               ("expect array type in instantiation of &", Actual, Gen_T);
7782             Abandon_Instantiation (Actual);
7783
7784          elsif Nkind (Def) = N_Constrained_Array_Definition then
7785             if not (Is_Constrained (Act_T)) then
7786                Error_Msg_NE
7787                  ("expect constrained array in instantiation of &",
7788                   Actual, Gen_T);
7789                Abandon_Instantiation (Actual);
7790             end if;
7791
7792          else
7793             if Is_Constrained (Act_T) then
7794                Error_Msg_NE
7795                  ("expect unconstrained array in instantiation of &",
7796                   Actual, Gen_T);
7797                Abandon_Instantiation (Actual);
7798             end if;
7799          end if;
7800
7801          if Formal_Dimensions /= Number_Dimensions (Act_T) then
7802             Error_Msg_NE
7803               ("dimensions of actual do not match formal &", Actual, Gen_T);
7804             Abandon_Instantiation (Actual);
7805          end if;
7806
7807          I1 := First_Index (A_Gen_T);
7808          I2 := First_Index (Act_T);
7809          for J in 1 .. Formal_Dimensions loop
7810
7811             --  If the indices of the actual were given by a subtype_mark,
7812             --  the index was transformed into a range attribute. Retrieve
7813             --  the original type mark for checking.
7814
7815             if Is_Entity_Name (Original_Node (I2)) then
7816                T2 := Entity (Original_Node (I2));
7817             else
7818                T2 := Etype (I2);
7819             end if;
7820
7821             if not Subtypes_Match
7822               (Find_Actual_Type (Etype (I1), Scope (A_Gen_T)), T2)
7823             then
7824                Error_Msg_NE
7825                  ("index types of actual do not match those of formal &",
7826                   Actual, Gen_T);
7827                Abandon_Instantiation (Actual);
7828             end if;
7829
7830             Next_Index (I1);
7831             Next_Index (I2);
7832          end loop;
7833
7834          if not Subtypes_Match (
7835             Find_Actual_Type (Component_Type (A_Gen_T), Scope (A_Gen_T)),
7836             Component_Type (Act_T))
7837          then
7838             Error_Msg_NE
7839               ("component subtype of actual does not match that of formal &",
7840                Actual, Gen_T);
7841             Abandon_Instantiation (Actual);
7842          end if;
7843
7844          if Has_Aliased_Components (A_Gen_T)
7845            and then not Has_Aliased_Components (Act_T)
7846          then
7847             Error_Msg_NE
7848               ("actual must have aliased components to match formal type &",
7849                Actual, Gen_T);
7850          end if;
7851
7852       end Validate_Array_Type_Instance;
7853
7854       ------------------------------------
7855       -- Validate_Derived_Type_Instance --
7856       ------------------------------------
7857
7858       procedure Validate_Derived_Type_Instance is
7859          Actual_Discr   : Entity_Id;
7860          Ancestor_Discr : Entity_Id;
7861
7862       begin
7863          --  If the parent type in the generic declaration is itself
7864          --  a previous formal type, then it is local to the generic
7865          --  and absent from the analyzed generic definition. In  that
7866          --  case the ancestor is the instance of the formal (which must
7867          --  have been instantiated previously), unless the ancestor is
7868          --  itself a formal derived type. In this latter case (which is the
7869          --  subject of Corrigendum 8652/0038 (AI-202) the ancestor of the
7870          --  formals is the ancestor of its parent. Otherwise, the analyzed
7871          --  generic carries the parent type. If the parent type is defined
7872          --  in a previous formal package, then the scope of that formal
7873          --  package is that of the generic type itself, and it has already
7874          --  been mapped into the corresponding type in the actual package.
7875
7876          --  Common case: parent type defined outside of the generic
7877
7878          if Is_Entity_Name (Subtype_Mark (Def))
7879            and then Present (Entity (Subtype_Mark (Def)))
7880          then
7881             Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
7882
7883          --  Check whether parent is defined in a previous formal package
7884
7885          elsif
7886            Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
7887          then
7888             Ancestor :=
7889               Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
7890
7891          --  The type may be a local derivation, or a type extension of
7892          --  a previous formal, or of a formal of a parent package.
7893
7894          elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T))
7895           or else
7896             Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
7897          then
7898             --  Check whether the parent is another derived formal type
7899             --  in the same generic unit.
7900
7901             if Etype (A_Gen_T) /= A_Gen_T
7902               and then Is_Generic_Type (Etype (A_Gen_T))
7903               and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
7904               and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
7905             then
7906                --  Locate ancestor of parent from the subtype declaration
7907                --  created for the actual.
7908
7909                declare
7910                   Decl : Node_Id;
7911
7912                begin
7913                   Decl := First (Actual_Decls);
7914                   while Present (Decl) loop
7915                      if Nkind (Decl) = N_Subtype_Declaration
7916                        and then Chars (Defining_Identifier (Decl)) =
7917                                                     Chars (Etype (A_Gen_T))
7918                      then
7919                         Ancestor := Generic_Parent_Type (Decl);
7920                         exit;
7921                      else
7922                         Next (Decl);
7923                      end if;
7924                   end loop;
7925                end;
7926
7927                pragma Assert (Present (Ancestor));
7928
7929             else
7930                Ancestor :=
7931                  Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
7932             end if;
7933
7934          else
7935             Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
7936          end if;
7937
7938          if not Is_Ancestor (Base_Type (Ancestor), Act_T) then
7939             Error_Msg_NE
7940               ("expect type derived from & in instantiation",
7941                Actual, First_Subtype (Ancestor));
7942             Abandon_Instantiation (Actual);
7943          end if;
7944
7945          --  Perform atomic/volatile checks (RM C.6(12))
7946
7947          if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
7948             Error_Msg_N
7949               ("cannot have atomic actual type for non-atomic formal type",
7950                Actual);
7951
7952          elsif Is_Volatile (Act_T)
7953            and then not Is_Volatile (Ancestor)
7954            and then Is_By_Reference_Type (Ancestor)
7955          then
7956             Error_Msg_N
7957               ("cannot have volatile actual type for non-volatile formal type",
7958                Actual);
7959          end if;
7960
7961          --  It should not be necessary to check for unknown discriminants
7962          --  on Formal, but for some reason Has_Unknown_Discriminants is
7963          --  false for A_Gen_T, so Is_Indefinite_Subtype incorrectly
7964          --  returns False. This needs fixing. ???
7965
7966          if not Is_Indefinite_Subtype (A_Gen_T)
7967            and then not Unknown_Discriminants_Present (Formal)
7968            and then Is_Indefinite_Subtype (Act_T)
7969          then
7970             Error_Msg_N
7971               ("actual subtype must be constrained", Actual);
7972             Abandon_Instantiation (Actual);
7973          end if;
7974
7975          if not Unknown_Discriminants_Present (Formal) then
7976             if Is_Constrained (Ancestor) then
7977                if not Is_Constrained (Act_T) then
7978                   Error_Msg_N
7979                     ("actual subtype must be constrained", Actual);
7980                   Abandon_Instantiation (Actual);
7981                end if;
7982
7983             --  Ancestor is unconstrained
7984
7985             elsif Is_Constrained (Act_T) then
7986                if Ekind (Ancestor) = E_Access_Type
7987                  or else Is_Composite_Type (Ancestor)
7988                then
7989                   Error_Msg_N
7990                     ("actual subtype must be unconstrained", Actual);
7991                   Abandon_Instantiation (Actual);
7992                end if;
7993
7994             --  A class-wide type is only allowed if the formal has
7995             --  unknown discriminants.
7996
7997             elsif Is_Class_Wide_Type (Act_T)
7998               and then not Has_Unknown_Discriminants (Ancestor)
7999             then
8000                Error_Msg_NE
8001                  ("actual for & cannot be a class-wide type", Actual, Gen_T);
8002                Abandon_Instantiation (Actual);
8003
8004             --  Otherwise, the formal and actual shall have the same
8005             --  number of discriminants and each discriminant of the
8006             --  actual must correspond to a discriminant of the formal.
8007
8008             elsif Has_Discriminants (Act_T)
8009               and then not Has_Unknown_Discriminants (Act_T)
8010               and then Has_Discriminants (Ancestor)
8011             then
8012                Actual_Discr   := First_Discriminant (Act_T);
8013                Ancestor_Discr := First_Discriminant (Ancestor);
8014                while Present (Actual_Discr)
8015                  and then Present (Ancestor_Discr)
8016                loop
8017                   if Base_Type (Act_T) /= Base_Type (Ancestor) and then
8018                     not Present (Corresponding_Discriminant (Actual_Discr))
8019                   then
8020                      Error_Msg_NE
8021                        ("discriminant & does not correspond " &
8022                         "to ancestor discriminant", Actual, Actual_Discr);
8023                      Abandon_Instantiation (Actual);
8024                   end if;
8025
8026                   Next_Discriminant (Actual_Discr);
8027                   Next_Discriminant (Ancestor_Discr);
8028                end loop;
8029
8030                if Present (Actual_Discr) or else Present (Ancestor_Discr) then
8031                   Error_Msg_NE
8032                     ("actual for & must have same number of discriminants",
8033                      Actual, Gen_T);
8034                   Abandon_Instantiation (Actual);
8035                end if;
8036
8037             --  This case should be caught by the earlier check for
8038             --  for constrainedness, but the check here is added for
8039             --  completeness.
8040
8041             elsif Has_Discriminants (Act_T)
8042               and then not Has_Unknown_Discriminants (Act_T)
8043             then
8044                Error_Msg_NE
8045                  ("actual for & must not have discriminants", Actual, Gen_T);
8046                Abandon_Instantiation (Actual);
8047
8048             elsif Has_Discriminants (Ancestor) then
8049                Error_Msg_NE
8050                  ("actual for & must have known discriminants", Actual, Gen_T);
8051                Abandon_Instantiation (Actual);
8052             end if;
8053
8054             if not Subtypes_Statically_Compatible (Act_T, Ancestor) then
8055                Error_Msg_N
8056                  ("constraint on actual is incompatible with formal", Actual);
8057                Abandon_Instantiation (Actual);
8058             end if;
8059          end if;
8060       end Validate_Derived_Type_Instance;
8061
8062       ------------------------------------
8063       -- Validate_Private_Type_Instance --
8064       ------------------------------------
8065
8066       procedure Validate_Private_Type_Instance is
8067          Formal_Discr : Entity_Id;
8068          Actual_Discr : Entity_Id;
8069          Formal_Subt  : Entity_Id;
8070
8071       begin
8072          if Is_Limited_Type (Act_T)
8073            and then not Is_Limited_Type (A_Gen_T)
8074          then
8075             Error_Msg_NE
8076               ("actual for non-limited  & cannot be a limited type", Actual,
8077                Gen_T);
8078             Explain_Limited_Type (Act_T, Actual);
8079             Abandon_Instantiation (Actual);
8080
8081          elsif Is_Indefinite_Subtype (Act_T)
8082             and then not Is_Indefinite_Subtype (A_Gen_T)
8083             and then Ada_Version >= Ada_95
8084          then
8085             Error_Msg_NE
8086               ("actual for & must be a definite subtype", Actual, Gen_T);
8087
8088          elsif not Is_Tagged_Type (Act_T)
8089            and then Is_Tagged_Type (A_Gen_T)
8090          then
8091             Error_Msg_NE
8092               ("actual for & must be a tagged type", Actual, Gen_T);
8093
8094          elsif Has_Discriminants (A_Gen_T) then
8095             if not Has_Discriminants (Act_T) then
8096                Error_Msg_NE
8097                  ("actual for & must have discriminants", Actual, Gen_T);
8098                Abandon_Instantiation (Actual);
8099
8100             elsif Is_Constrained (Act_T) then
8101                Error_Msg_NE
8102                  ("actual for & must be unconstrained", Actual, Gen_T);
8103                Abandon_Instantiation (Actual);
8104
8105             else
8106                Formal_Discr := First_Discriminant (A_Gen_T);
8107                Actual_Discr := First_Discriminant (Act_T);
8108                while Formal_Discr /= Empty loop
8109                   if Actual_Discr = Empty then
8110                      Error_Msg_NE
8111                        ("discriminants on actual do not match formal",
8112                         Actual, Gen_T);
8113                      Abandon_Instantiation (Actual);
8114                   end if;
8115
8116                   Formal_Subt := Get_Instance_Of (Etype (Formal_Discr));
8117
8118                   --  access discriminants match if designated types do.
8119
8120                   if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
8121                     and then (Ekind (Base_Type (Etype (Actual_Discr))))
8122                       = E_Anonymous_Access_Type
8123                     and then Get_Instance_Of (
8124                       Designated_Type (Base_Type (Formal_Subt)))
8125                       = Designated_Type (Base_Type (Etype (Actual_Discr)))
8126                   then
8127                      null;
8128
8129                   elsif Base_Type (Formal_Subt) /=
8130                                        Base_Type (Etype (Actual_Discr))
8131                   then
8132                      Error_Msg_NE
8133                        ("types of actual discriminants must match formal",
8134                         Actual, Gen_T);
8135                      Abandon_Instantiation (Actual);
8136
8137                   elsif not Subtypes_Statically_Match
8138                               (Formal_Subt, Etype (Actual_Discr))
8139                     and then Ada_Version >= Ada_95
8140                   then
8141                      Error_Msg_NE
8142                        ("subtypes of actual discriminants must match formal",
8143                         Actual, Gen_T);
8144                      Abandon_Instantiation (Actual);
8145                   end if;
8146
8147                   Next_Discriminant (Formal_Discr);
8148                   Next_Discriminant (Actual_Discr);
8149                end loop;
8150
8151                if Actual_Discr /= Empty then
8152                   Error_Msg_NE
8153                     ("discriminants on actual do not match formal",
8154                      Actual, Gen_T);
8155                   Abandon_Instantiation (Actual);
8156                end if;
8157             end if;
8158
8159          end if;
8160
8161          Ancestor := Gen_T;
8162       end Validate_Private_Type_Instance;
8163
8164    --  Start of processing for Instantiate_Type
8165
8166    begin
8167       if Get_Instance_Of (A_Gen_T) /= A_Gen_T then
8168          Error_Msg_N ("duplicate instantiation of generic type", Actual);
8169          return Error;
8170
8171       elsif not Is_Entity_Name (Actual)
8172         or else not Is_Type (Entity (Actual))
8173       then
8174          Error_Msg_NE
8175            ("expect valid subtype mark to instantiate &", Actual, Gen_T);
8176          Abandon_Instantiation (Actual);
8177
8178       else
8179          Act_T := Entity (Actual);
8180
8181          --  Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
8182          --  as a generic actual parameter if the corresponding formal type
8183          --  does not have a known_discriminant_part, or is a formal derived
8184          --  type that is an Unchecked_Union type.
8185
8186          if Is_Unchecked_Union (Base_Type (Act_T)) then
8187             if not Has_Discriminants (A_Gen_T)
8188                      or else
8189                    (Is_Derived_Type (A_Gen_T)
8190                      and then
8191                     Is_Unchecked_Union (A_Gen_T))
8192             then
8193                null;
8194             else
8195                Error_Msg_N ("Unchecked_Union cannot be the actual for a" &
8196                  " discriminated formal type", Act_T);
8197
8198             end if;
8199          end if;
8200
8201          --  Deal with fixed/floating restrictions
8202
8203          if Is_Floating_Point_Type (Act_T) then
8204             Check_Restriction (No_Floating_Point, Actual);
8205          elsif Is_Fixed_Point_Type (Act_T) then
8206             Check_Restriction (No_Fixed_Point, Actual);
8207          end if;
8208
8209          --  Deal with error of using incomplete type as generic actual
8210
8211          if Ekind (Act_T) = E_Incomplete_Type then
8212             if No (Underlying_Type (Act_T)) then
8213                Error_Msg_N ("premature use of incomplete type", Actual);
8214                Abandon_Instantiation (Actual);
8215             else
8216                Act_T := Full_View (Act_T);
8217                Set_Entity (Actual, Act_T);
8218
8219                if Has_Private_Component (Act_T) then
8220                   Error_Msg_N
8221                     ("premature use of type with private component", Actual);
8222                end if;
8223             end if;
8224
8225          --  Deal with error of premature use of private type as generic actual
8226
8227          elsif Is_Private_Type (Act_T)
8228            and then Is_Private_Type (Base_Type (Act_T))
8229            and then not Is_Generic_Type (Act_T)
8230            and then not Is_Derived_Type (Act_T)
8231            and then No (Full_View (Root_Type (Act_T)))
8232          then
8233             Error_Msg_N ("premature use of private type", Actual);
8234
8235          elsif Has_Private_Component (Act_T) then
8236             Error_Msg_N
8237               ("premature use of type with private component", Actual);
8238          end if;
8239
8240          Set_Instance_Of (A_Gen_T, Act_T);
8241
8242          --  If the type is generic, the class-wide type may also be used
8243
8244          if Is_Tagged_Type (A_Gen_T)
8245            and then Is_Tagged_Type (Act_T)
8246            and then not Is_Class_Wide_Type (A_Gen_T)
8247          then
8248             Set_Instance_Of (Class_Wide_Type (A_Gen_T),
8249               Class_Wide_Type (Act_T));
8250          end if;
8251
8252          if not Is_Abstract (A_Gen_T)
8253            and then Is_Abstract (Act_T)
8254          then
8255             Error_Msg_N
8256               ("actual of non-abstract formal cannot be abstract", Actual);
8257          end if;
8258
8259          if Is_Scalar_Type (Gen_T) then
8260             Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T));
8261          end if;
8262       end if;
8263
8264       case Nkind (Def) is
8265          when N_Formal_Private_Type_Definition =>
8266             Validate_Private_Type_Instance;
8267
8268          when N_Formal_Derived_Type_Definition =>
8269             Validate_Derived_Type_Instance;
8270
8271          when N_Formal_Discrete_Type_Definition =>
8272             if not Is_Discrete_Type (Act_T) then
8273                Error_Msg_NE
8274                  ("expect discrete type in instantiation of&", Actual, Gen_T);
8275                Abandon_Instantiation (Actual);
8276             end if;
8277
8278          when N_Formal_Signed_Integer_Type_Definition =>
8279             if not Is_Signed_Integer_Type (Act_T) then
8280                Error_Msg_NE
8281                  ("expect signed integer type in instantiation of&",
8282                   Actual, Gen_T);
8283                Abandon_Instantiation (Actual);
8284             end if;
8285
8286          when N_Formal_Modular_Type_Definition =>
8287             if not Is_Modular_Integer_Type (Act_T) then
8288                Error_Msg_NE
8289                  ("expect modular type in instantiation of &", Actual, Gen_T);
8290                Abandon_Instantiation (Actual);
8291             end if;
8292
8293          when N_Formal_Floating_Point_Definition =>
8294             if not Is_Floating_Point_Type (Act_T) then
8295                Error_Msg_NE
8296                  ("expect float type in instantiation of &", Actual, Gen_T);
8297                Abandon_Instantiation (Actual);
8298             end if;
8299
8300          when N_Formal_Ordinary_Fixed_Point_Definition =>
8301             if not Is_Ordinary_Fixed_Point_Type (Act_T) then
8302                Error_Msg_NE
8303                  ("expect ordinary fixed point type in instantiation of &",
8304                   Actual, Gen_T);
8305                Abandon_Instantiation (Actual);
8306             end if;
8307
8308          when N_Formal_Decimal_Fixed_Point_Definition =>
8309             if not Is_Decimal_Fixed_Point_Type (Act_T) then
8310                Error_Msg_NE
8311                  ("expect decimal type in instantiation of &",
8312                   Actual, Gen_T);
8313                Abandon_Instantiation (Actual);
8314             end if;
8315
8316          when N_Array_Type_Definition =>
8317             Validate_Array_Type_Instance;
8318
8319          when N_Access_To_Object_Definition =>
8320             Validate_Access_Type_Instance;
8321
8322          when N_Access_Function_Definition |
8323               N_Access_Procedure_Definition =>
8324             Validate_Access_Subprogram_Instance;
8325
8326          when others =>
8327             raise Program_Error;
8328
8329       end case;
8330
8331       Decl_Node :=
8332         Make_Subtype_Declaration (Loc,
8333           Defining_Identifier => New_Copy (Gen_T),
8334           Subtype_Indication  => New_Reference_To (Act_T, Loc));
8335
8336       if Is_Private_Type (Act_T) then
8337          Set_Has_Private_View (Subtype_Indication (Decl_Node));
8338
8339       elsif Is_Access_Type (Act_T)
8340         and then Is_Private_Type (Designated_Type (Act_T))
8341       then
8342          Set_Has_Private_View (Subtype_Indication (Decl_Node));
8343       end if;
8344
8345       --  Flag actual derived types so their elaboration produces the
8346       --  appropriate renamings for the primitive operations of the ancestor.
8347       --  Flag actual for formal private types as well, to determine whether
8348       --  operations in the private part may override inherited operations.
8349
8350       if Nkind (Def) = N_Formal_Derived_Type_Definition
8351         or else Nkind (Def) = N_Formal_Private_Type_Definition
8352       then
8353          Set_Generic_Parent_Type (Decl_Node, Ancestor);
8354       end if;
8355
8356       return Decl_Node;
8357    end Instantiate_Type;
8358
8359    ---------------------
8360    -- Is_In_Main_Unit --
8361    ---------------------
8362
8363    function Is_In_Main_Unit (N : Node_Id) return Boolean is
8364       Unum : constant Unit_Number_Type := Get_Source_Unit (N);
8365
8366       Current_Unit : Node_Id;
8367
8368    begin
8369       if Unum = Main_Unit then
8370          return True;
8371
8372       --  If the current unit is a subunit then it is either the main unit
8373       --  or is being compiled as part of the main unit.
8374
8375       elsif Nkind (N) = N_Compilation_Unit then
8376          return Nkind (Unit (N)) = N_Subunit;
8377       end if;
8378
8379       Current_Unit := Parent (N);
8380       while Present (Current_Unit)
8381         and then Nkind (Current_Unit) /= N_Compilation_Unit
8382       loop
8383          Current_Unit := Parent (Current_Unit);
8384       end loop;
8385
8386       --  The instantiation node is in the main unit, or else the current
8387       --  node (perhaps as the result of nested instantiations) is in the
8388       --  main unit, or in the declaration of the main unit, which in this
8389       --  last case must be a body.
8390
8391       return Unum = Main_Unit
8392         or else Current_Unit = Cunit (Main_Unit)
8393         or else Current_Unit = Library_Unit (Cunit (Main_Unit))
8394         or else (Present (Library_Unit (Current_Unit))
8395                   and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
8396    end Is_In_Main_Unit;
8397
8398    ----------------------------
8399    -- Load_Parent_Of_Generic --
8400    ----------------------------
8401
8402    procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id) is
8403       Comp_Unit        : constant Node_Id := Cunit (Get_Source_Unit (Spec));
8404       Save_Style_Check : constant Boolean := Style_Check;
8405       True_Parent      : Node_Id;
8406       Inst_Node        : Node_Id;
8407       OK               : Boolean;
8408
8409    begin
8410       if not In_Same_Source_Unit (N, Spec)
8411         or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration
8412         or else (Nkind (Unit (Comp_Unit)) = N_Package_Body
8413                    and then not Is_In_Main_Unit (Spec))
8414       then
8415          --  Find body of parent of spec, and analyze it. A special case
8416          --  arises when the parent is an instantiation, that is to say when
8417          --  we are currently instantiating a nested generic. In that case,
8418          --  there is no separate file for the body of the enclosing instance.
8419          --  Instead, the enclosing body must be instantiated as if it were
8420          --  a pending instantiation, in order to produce the body for the
8421          --  nested generic we require now. Note that in that case the
8422          --  generic may be defined in a package body, the instance defined
8423          --  in the same package body, and the original enclosing body may not
8424          --  be in the main unit.
8425
8426          True_Parent := Parent (Spec);
8427          Inst_Node   := Empty;
8428
8429          while Present (True_Parent)
8430            and then Nkind (True_Parent) /= N_Compilation_Unit
8431          loop
8432             if Nkind (True_Parent) = N_Package_Declaration
8433               and then
8434                 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
8435             then
8436                --  Parent is a compilation unit that is an instantiation.
8437                --  Instantiation node has been replaced with package decl.
8438
8439                Inst_Node := Original_Node (True_Parent);
8440                exit;
8441
8442             elsif Nkind (True_Parent) = N_Package_Declaration
8443               and then Present (Generic_Parent (Specification (True_Parent)))
8444               and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit
8445             then
8446                --  Parent is an instantiation within another specification.
8447                --  Declaration for instance has been inserted before original
8448                --  instantiation node. A direct link would be preferable?
8449
8450                Inst_Node := Next (True_Parent);
8451
8452                while Present (Inst_Node)
8453                  and then Nkind (Inst_Node) /= N_Package_Instantiation
8454                loop
8455                   Next (Inst_Node);
8456                end loop;
8457
8458                --  If the instance appears within a generic, and the generic
8459                --  unit is defined within a formal package of the enclosing
8460                --  generic, there is no generic body available, and none
8461                --  needed. A more precise test should be used ???
8462
8463                if No (Inst_Node) then
8464                   return;
8465                end if;
8466
8467                exit;
8468             else
8469                True_Parent := Parent (True_Parent);
8470             end if;
8471          end loop;
8472
8473          --  Case where we are currently instantiating a nested generic
8474
8475          if Present (Inst_Node) then
8476             if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
8477
8478                --  Instantiation node and declaration of instantiated package
8479                --  were exchanged when only the declaration was needed.
8480                --  Restore instantiation node before proceeding with body.
8481
8482                Set_Unit (Parent (True_Parent), Inst_Node);
8483             end if;
8484
8485             --  Now complete instantiation of enclosing body, if it appears
8486             --  in some other unit. If it appears in the current unit, the
8487             --  body will have been instantiated already.
8488
8489             if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
8490
8491                --  We need to determine the expander mode to instantiate
8492                --  the enclosing body. Because the generic body we need
8493                --  may use global entities declared in the enclosing package
8494                --  (including aggregates) it is in general necessary to
8495                --  compile this body with expansion enabled. The exception
8496                --  is if we are within a generic package, in which case
8497                --  the usual generic rule applies.
8498
8499                declare
8500                   Exp_Status : Boolean := True;
8501                   Scop       : Entity_Id;
8502
8503                begin
8504                   --  Loop through scopes looking for generic package
8505
8506                   Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node)));
8507                   while Present (Scop)
8508                     and then Scop /= Standard_Standard
8509                   loop
8510                      if Ekind (Scop) = E_Generic_Package then
8511                         Exp_Status := False;
8512                         exit;
8513                      end if;
8514
8515                      Scop := Scope (Scop);
8516                   end loop;
8517
8518                   Instantiate_Package_Body
8519                     (Pending_Body_Info'(
8520                        Inst_Node, True_Parent, Exp_Status,
8521                          Get_Code_Unit (Sloc (Inst_Node))));
8522                end;
8523             end if;
8524
8525          --  Case where we are not instantiating a nested generic
8526
8527          else
8528             Opt.Style_Check := False;
8529             Expander_Mode_Save_And_Set (True);
8530             Load_Needed_Body (Comp_Unit, OK);
8531             Opt.Style_Check := Save_Style_Check;
8532             Expander_Mode_Restore;
8533
8534             if not OK
8535               and then Unit_Requires_Body (Defining_Entity (Spec))
8536             then
8537                declare
8538                   Bname : constant Unit_Name_Type :=
8539                             Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
8540
8541                begin
8542                   Error_Msg_Unit_1 := Bname;
8543                   Error_Msg_N ("this instantiation requires$!", N);
8544                   Error_Msg_Name_1 :=
8545                     Get_File_Name (Bname, Subunit => False);
8546                   Error_Msg_N ("\but file{ was not found!", N);
8547                   raise Unrecoverable_Error;
8548                end;
8549             end if;
8550          end if;
8551       end if;
8552
8553       --  If loading the parent of the generic caused an instantiation
8554       --  circularity, we abandon compilation at this point, because
8555       --  otherwise in some cases we get into trouble with infinite
8556       --  recursions after this point.
8557
8558       if Circularity_Detected then
8559          raise Unrecoverable_Error;
8560       end if;
8561    end Load_Parent_Of_Generic;
8562
8563    -----------------------
8564    -- Move_Freeze_Nodes --
8565    -----------------------
8566
8567    procedure Move_Freeze_Nodes
8568      (Out_Of : Entity_Id;
8569       After  : Node_Id;
8570       L      : List_Id)
8571    is
8572       Decl      : Node_Id;
8573       Next_Decl : Node_Id;
8574       Next_Node : Node_Id := After;
8575       Spec      : Node_Id;
8576
8577       function Is_Outer_Type (T : Entity_Id) return Boolean;
8578       --  Check whether entity is declared in a scope external to that
8579       --  of the generic unit.
8580
8581       -------------------
8582       -- Is_Outer_Type --
8583       -------------------
8584
8585       function Is_Outer_Type (T : Entity_Id) return Boolean is
8586          Scop : Entity_Id := Scope (T);
8587
8588       begin
8589          if Scope_Depth (Scop) < Scope_Depth (Out_Of) then
8590             return True;
8591
8592          else
8593             while Scop /= Standard_Standard loop
8594
8595                if Scop = Out_Of then
8596                   return False;
8597                else
8598                   Scop := Scope (Scop);
8599                end if;
8600             end loop;
8601
8602             return True;
8603          end if;
8604       end Is_Outer_Type;
8605
8606    --  Start of processing for Move_Freeze_Nodes
8607
8608    begin
8609       if No (L) then
8610          return;
8611       end if;
8612
8613       --  First remove the freeze nodes that may appear before all other
8614       --  declarations.
8615
8616       Decl := First (L);
8617       while Present (Decl)
8618         and then Nkind (Decl) = N_Freeze_Entity
8619         and then Is_Outer_Type (Entity (Decl))
8620       loop
8621          Decl := Remove_Head (L);
8622          Insert_After (Next_Node, Decl);
8623          Set_Analyzed (Decl, False);
8624          Next_Node := Decl;
8625          Decl := First (L);
8626       end loop;
8627
8628       --  Next scan the list of declarations and remove each freeze node that
8629       --  appears ahead of the current node.
8630
8631       while Present (Decl) loop
8632          while Present (Next (Decl))
8633            and then Nkind (Next (Decl)) = N_Freeze_Entity
8634            and then Is_Outer_Type (Entity (Next (Decl)))
8635          loop
8636             Next_Decl := Remove_Next (Decl);
8637             Insert_After (Next_Node, Next_Decl);
8638             Set_Analyzed (Next_Decl, False);
8639             Next_Node := Next_Decl;
8640          end loop;
8641
8642          --  If the declaration is a nested package or concurrent type, then
8643          --  recurse. Nested generic packages will have been processed from the
8644          --  inside out.
8645
8646          if Nkind (Decl) = N_Package_Declaration then
8647             Spec := Specification (Decl);
8648
8649          elsif Nkind (Decl) = N_Task_Type_Declaration then
8650             Spec := Task_Definition (Decl);
8651
8652          elsif Nkind (Decl) = N_Protected_Type_Declaration then
8653             Spec := Protected_Definition (Decl);
8654
8655          else
8656             Spec := Empty;
8657          end if;
8658
8659          if Present (Spec) then
8660             Move_Freeze_Nodes (Out_Of, Next_Node,
8661               Visible_Declarations (Spec));
8662             Move_Freeze_Nodes (Out_Of, Next_Node,
8663               Private_Declarations (Spec));
8664          end if;
8665
8666          Next (Decl);
8667       end loop;
8668    end Move_Freeze_Nodes;
8669
8670    ----------------
8671    -- Next_Assoc --
8672    ----------------
8673
8674    function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is
8675    begin
8676       return Generic_Renamings.Table (E).Next_In_HTable;
8677    end Next_Assoc;
8678
8679    ------------------------
8680    -- Preanalyze_Actuals --
8681    ------------------------
8682
8683    procedure Pre_Analyze_Actuals (N : Node_Id) is
8684       Assoc : Node_Id;
8685       Act   : Node_Id;
8686       Errs  : constant Int := Serious_Errors_Detected;
8687
8688    begin
8689       Assoc := First (Generic_Associations (N));
8690
8691       while Present (Assoc) loop
8692          Act := Explicit_Generic_Actual_Parameter (Assoc);
8693
8694          --  Within a nested instantiation, a defaulted actual is an
8695          --  empty association, so nothing to analyze. If the actual for
8696          --  a subprogram is an attribute, analyze prefix only, because
8697          --  actual is not a complete attribute reference.
8698
8699          --  If actual is an allocator, analyze expression only. The full
8700          --  analysis can generate code, and if the instance is a compilation
8701          --  unit we have to wait until the package instance is installed to
8702          --  have a proper place to insert this code.
8703
8704          --  String literals may be operators, but at this point we do not
8705          --  know whether the actual is a formal subprogram or a string.
8706
8707          if No (Act) then
8708             null;
8709
8710          elsif Nkind (Act) = N_Attribute_Reference then
8711             Analyze (Prefix (Act));
8712
8713          elsif Nkind (Act) = N_Explicit_Dereference then
8714             Analyze (Prefix (Act));
8715
8716          elsif Nkind (Act) = N_Allocator then
8717             declare
8718                Expr : constant Node_Id := Expression (Act);
8719
8720             begin
8721                if Nkind (Expr) = N_Subtype_Indication then
8722                   Analyze (Subtype_Mark (Expr));
8723                   Analyze_List (Constraints (Constraint (Expr)));
8724                else
8725                   Analyze (Expr);
8726                end if;
8727             end;
8728
8729          elsif Nkind (Act) /= N_Operator_Symbol then
8730             Analyze (Act);
8731          end if;
8732
8733          if Errs /= Serious_Errors_Detected then
8734             Abandon_Instantiation (Act);
8735          end if;
8736
8737          Next (Assoc);
8738       end loop;
8739    end Pre_Analyze_Actuals;
8740
8741    -------------------
8742    -- Remove_Parent --
8743    -------------------
8744
8745    procedure Remove_Parent (In_Body : Boolean := False) is
8746       S      : Entity_Id := Current_Scope;
8747       E      : Entity_Id;
8748       P      : Entity_Id;
8749       Hidden : Elmt_Id;
8750
8751    begin
8752       --  After child instantiation is complete, remove from scope stack
8753       --  the extra copy of the current scope, and then remove parent
8754       --  instances.
8755
8756       if not In_Body then
8757          Pop_Scope;
8758
8759          while Current_Scope /= S loop
8760             P := Current_Scope;
8761             End_Package_Scope (Current_Scope);
8762
8763             if In_Open_Scopes (P) then
8764                E := First_Entity (P);
8765
8766                while Present (E) loop
8767                   Set_Is_Immediately_Visible (E, True);
8768                   Next_Entity (E);
8769                end loop;
8770
8771                if Is_Generic_Instance (Current_Scope)
8772                  and then P /= Current_Scope
8773                then
8774                   --  We are within an instance of some sibling. Retain
8775                   --  visibility of parent, for proper subsequent cleanup.
8776
8777                   Set_In_Private_Part (P);
8778                end if;
8779
8780             --  This looks incomplete: what about compilation units that
8781             --  were made visible by Install_Parent but should not remain
8782             --  visible??? Standard is on the scope stack.
8783
8784             elsif not In_Open_Scopes (Scope (P)) then
8785                Set_Is_Immediately_Visible (P, False);
8786             end if;
8787          end loop;
8788
8789          --  Reset visibility of entities in the enclosing scope.
8790
8791          Set_Is_Hidden_Open_Scope (Current_Scope, False);
8792          Hidden := First_Elmt (Hidden_Entities);
8793
8794          while Present (Hidden) loop
8795             Set_Is_Immediately_Visible (Node (Hidden), True);
8796             Next_Elmt (Hidden);
8797          end loop;
8798
8799       else
8800          --  Each body is analyzed separately, and there is no context
8801          --  that needs preserving from one body instance to the next,
8802          --  so remove all parent scopes that have been installed.
8803
8804          while Present (S) loop
8805             End_Package_Scope (S);
8806             Set_Is_Immediately_Visible (S, False);
8807             S := Current_Scope;
8808             exit when S = Standard_Standard;
8809          end loop;
8810       end if;
8811
8812    end Remove_Parent;
8813
8814    -----------------
8815    -- Restore_Env --
8816    -----------------
8817
8818    procedure Restore_Env is
8819       Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
8820
8821    begin
8822       Ada_Version := Saved.Ada_Version;
8823
8824       if No (Current_Instantiated_Parent.Act_Id) then
8825
8826          --  Restore environment after subprogram inlining
8827
8828          Restore_Private_Views (Empty);
8829       end if;
8830
8831       Current_Instantiated_Parent  := Saved.Instantiated_Parent;
8832       Exchanged_Views              := Saved.Exchanged_Views;
8833       Hidden_Entities              := Saved.Hidden_Entities;
8834       Current_Sem_Unit             := Saved.Current_Sem_Unit;
8835
8836       Instance_Envs.Decrement_Last;
8837    end Restore_Env;
8838
8839    ---------------------------
8840    -- Restore_Private_Views --
8841    ---------------------------
8842
8843    procedure Restore_Private_Views
8844      (Pack_Id    : Entity_Id;
8845       Is_Package : Boolean := True)
8846    is
8847       M        : Elmt_Id;
8848       E        : Entity_Id;
8849       Typ      : Entity_Id;
8850       Dep_Elmt : Elmt_Id;
8851       Dep_Typ  : Node_Id;
8852
8853    begin
8854       M := First_Elmt (Exchanged_Views);
8855       while Present (M) loop
8856          Typ := Node (M);
8857
8858          --  Subtypes of types whose views have been exchanged, and that
8859          --  are defined within the instance, were not on the list of
8860          --  Private_Dependents on entry to the instance, so they have to
8861          --  be exchanged explicitly now, in order to remain consistent with
8862          --  the view of the parent type.
8863
8864          if Ekind (Typ) = E_Private_Type
8865            or else Ekind (Typ) = E_Limited_Private_Type
8866            or else Ekind (Typ) = E_Record_Type_With_Private
8867          then
8868             Dep_Elmt := First_Elmt (Private_Dependents (Typ));
8869
8870             while Present (Dep_Elmt) loop
8871                Dep_Typ := Node (Dep_Elmt);
8872
8873                if Scope (Dep_Typ) = Pack_Id
8874                  and then Present (Full_View (Dep_Typ))
8875                then
8876                   Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ));
8877                   Exchange_Declarations (Dep_Typ);
8878                end if;
8879
8880                Next_Elmt (Dep_Elmt);
8881             end loop;
8882          end if;
8883
8884          Exchange_Declarations (Node (M));
8885          Next_Elmt (M);
8886       end loop;
8887
8888       if No (Pack_Id) then
8889          return;
8890       end if;
8891
8892       --  Make the generic formal parameters private, and make the formal
8893       --  types into subtypes of the actuals again.
8894
8895       E := First_Entity (Pack_Id);
8896
8897       while Present (E) loop
8898          Set_Is_Hidden (E, True);
8899
8900          if Is_Type (E)
8901            and then Nkind (Parent (E)) = N_Subtype_Declaration
8902          then
8903             Set_Is_Generic_Actual_Type (E, False);
8904
8905             --  An unusual case of aliasing: the actual may also be directly
8906             --  visible in the generic, and be private there, while it is
8907             --  fully visible in the context of the instance. The internal
8908             --  subtype is private in the instance, but has full visibility
8909             --  like its parent in the enclosing scope. This enforces the
8910             --  invariant that the privacy status of all private dependents of
8911             --  a type coincide with that of the parent type. This can only
8912             --  happen when a generic child unit is instantiated within a
8913             --  sibling.
8914
8915             if Is_Private_Type (E)
8916               and then not Is_Private_Type (Etype (E))
8917             then
8918                Exchange_Declarations (E);
8919             end if;
8920
8921          elsif Ekind (E) = E_Package then
8922
8923             --  The end of the renaming list is the renaming of the generic
8924             --  package itself. If the instance is a subprogram, all entities
8925             --  in the corresponding package are renamings. If this entity is
8926             --  a formal package, make its own formals private as well. The
8927             --  actual in this case is itself the renaming of an instantation.
8928             --  If the entity is not a package renaming, it is the entity
8929             --  created to validate formal package actuals: ignore.
8930
8931             --  If the actual is itself a formal package for the enclosing
8932             --  generic, or the actual for such a formal package, it remains
8933             --  visible after the current instance, and therefore nothing
8934             --  needs to be done either, except to keep it accessible.
8935
8936             if Is_Package
8937               and then Renamed_Object (E) = Pack_Id
8938             then
8939                exit;
8940
8941             elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
8942                null;
8943
8944             elsif Denotes_Formal_Package (Renamed_Object (E)) then
8945                Set_Is_Hidden (E, False);
8946
8947             else
8948                declare
8949                   Act_P : constant Entity_Id := Renamed_Object (E);
8950                   Id    : Entity_Id;
8951
8952                begin
8953                   Id := First_Entity (Act_P);
8954                   while Present (Id)
8955                     and then Id /= First_Private_Entity (Act_P)
8956                   loop
8957                      Set_Is_Hidden (Id, True);
8958                      Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
8959                      exit when Ekind (Id) = E_Package
8960                                  and then Renamed_Object (Id) = Act_P;
8961
8962                      Next_Entity (Id);
8963                   end loop;
8964                end;
8965                null;
8966             end if;
8967          end if;
8968
8969          Next_Entity (E);
8970       end loop;
8971    end Restore_Private_Views;
8972
8973    --------------
8974    -- Save_Env --
8975    --------------
8976
8977    procedure Save_Env
8978      (Gen_Unit : Entity_Id;
8979       Act_Unit : Entity_Id)
8980    is
8981    begin
8982       Init_Env;
8983       Set_Instance_Env (Gen_Unit, Act_Unit);
8984    end Save_Env;
8985
8986    ----------------------------
8987    -- Save_Global_References --
8988    ----------------------------
8989
8990    procedure Save_Global_References (N : Node_Id) is
8991       Gen_Scope : Entity_Id;
8992       E         : Entity_Id;
8993       N2        : Node_Id;
8994
8995       function Is_Global (E : Entity_Id) return Boolean;
8996       --  Check whether entity is defined outside of generic unit.
8997       --  Examine the scope of an entity, and the scope of the scope,
8998       --  etc, until we find either Standard, in which case the entity
8999       --  is global, or the generic unit itself, which indicates that
9000       --  the entity is local. If the entity is the generic unit itself,
9001       --  as in the case of a recursive call, or the enclosing generic unit,
9002       --  if different from the current scope, then it is local as well,
9003       --  because it will be replaced at the point of instantiation. On
9004       --  the other hand, if it is a reference to a child unit of a common
9005       --  ancestor, which appears in an instantiation, it is global because
9006       --  it is used to denote a specific compilation unit at the time the
9007       --  instantiations will be analyzed.
9008
9009       procedure Reset_Entity (N : Node_Id);
9010       --  Save semantic information on global entity, so that it is not
9011       --  resolved again at instantiation time.
9012
9013       procedure Save_Entity_Descendants (N : Node_Id);
9014       --  Apply Save_Global_References to the two syntactic descendants of
9015       --  non-terminal nodes that carry an Associated_Node and are processed
9016       --  through Reset_Entity. Once the global entity (if any) has been
9017       --  captured together with its type, only two syntactic descendants
9018       --  need to be traversed to complete the processing of the tree rooted
9019       --  at N. This applies to Selected_Components, Expanded_Names, and to
9020       --  Operator nodes. N can also be a character literal, identifier, or
9021       --  operator symbol node, but the call has no effect in these cases.
9022
9023       procedure Save_Global_Defaults (N1, N2 : Node_Id);
9024       --  Default actuals in nested instances must be handled specially
9025       --  because there is no link to them from the original tree. When an
9026       --  actual subprogram is given by a default, we add an explicit generic
9027       --  association for it in the instantiation node. When we save the
9028       --  global references on the name of the instance, we recover the list
9029       --  of generic associations, and add an explicit one to the original
9030       --  generic tree, through which a global actual can be preserved.
9031       --  Similarly, if a child unit is instantiated within a sibling, in the
9032       --  context of the parent, we must preserve the identifier of the parent
9033       --  so that it can be properly resolved in a subsequent instantiation.
9034
9035       procedure Save_Global_Descendant (D : Union_Id);
9036       --  Apply Save_Global_References recursively to the descendents of
9037       --  current node.
9038
9039       procedure Save_References (N : Node_Id);
9040       --  This is the recursive procedure that does the work, once the
9041       --  enclosing generic scope has been established.
9042
9043       ---------------
9044       -- Is_Global --
9045       ---------------
9046
9047       function Is_Global (E : Entity_Id) return Boolean is
9048          Se  : Entity_Id := Scope (E);
9049
9050          function Is_Instance_Node (Decl : Node_Id) return Boolean;
9051          --  Determine whether the parent node of a reference to a child unit
9052          --  denotes an instantiation or a formal package, in which case the
9053          --  reference to the child unit is global, even if it appears within
9054          --  the current scope (e.g. when the instance appears within the body
9055          --  of an ancestor).
9056
9057          function Is_Instance_Node (Decl : Node_Id) return Boolean is
9058          begin
9059             return (Nkind (Decl) in N_Generic_Instantiation
9060               or else
9061                 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration);
9062          end Is_Instance_Node;
9063
9064       --  Start of processing for Is_Global
9065
9066       begin
9067          if E = Gen_Scope then
9068             return False;
9069
9070          elsif E = Standard_Standard then
9071             return True;
9072
9073          elsif Is_Child_Unit (E)
9074            and then (Is_Instance_Node (Parent (N2))
9075              or else (Nkind (Parent (N2)) = N_Expanded_Name
9076                        and then N2 = Selector_Name (Parent (N2))
9077                        and then Is_Instance_Node (Parent (Parent (N2)))))
9078          then
9079             return True;
9080
9081          else
9082             while Se /= Gen_Scope loop
9083                if Se = Standard_Standard then
9084                   return True;
9085                else
9086                   Se := Scope (Se);
9087                end if;
9088             end loop;
9089
9090             return False;
9091          end if;
9092       end Is_Global;
9093
9094       ------------------
9095       -- Reset_Entity --
9096       ------------------
9097
9098       procedure Reset_Entity (N : Node_Id) is
9099
9100          procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
9101          --  The type of N2 is global to the generic unit. Save the
9102          --  type in the generic node.
9103
9104          function Top_Ancestor (E : Entity_Id) return Entity_Id;
9105          --  Find the ultimate ancestor of the current unit. If it is
9106          --  not a generic unit, then the name of the current unit
9107          --  in the prefix of an expanded name must be replaced with
9108          --  its generic homonym to ensure that it will be properly
9109          --  resolved in an instance.
9110
9111          ---------------------
9112          -- Set_Global_Type --
9113          ---------------------
9114
9115          procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
9116             Typ : constant Entity_Id := Etype (N2);
9117
9118          begin
9119             Set_Etype (N, Typ);
9120
9121             if Entity (N) /= N2
9122               and then Has_Private_View (Entity (N))
9123             then
9124                --  If the entity of N is not the associated node, this is
9125                --  a nested generic and it has an associated node as well,
9126                --  whose type is already the full view (see below). Indicate
9127                --  that the original node has a private view.
9128
9129                Set_Has_Private_View (N);
9130             end if;
9131
9132             --  If not a private type, nothing else to do
9133
9134             if not Is_Private_Type (Typ) then
9135                if Is_Array_Type (Typ)
9136                  and then Is_Private_Type (Component_Type (Typ))
9137                then
9138                   Set_Has_Private_View (N);
9139                end if;
9140
9141             --  If it is a derivation of a private type in a context where
9142             --  no full view is needed, nothing to do either.
9143
9144             elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
9145                null;
9146
9147             --  Otherwise mark the type for flipping and use the full_view
9148             --  when available.
9149
9150             else
9151                Set_Has_Private_View (N);
9152
9153                if Present (Full_View (Typ)) then
9154                   Set_Etype (N2, Full_View (Typ));
9155                end if;
9156             end if;
9157          end Set_Global_Type;
9158
9159          ------------------
9160          -- Top_Ancestor --
9161          ------------------
9162
9163          function Top_Ancestor (E : Entity_Id) return Entity_Id is
9164             Par : Entity_Id := E;
9165
9166          begin
9167             while Is_Child_Unit (Par) loop
9168                Par := Scope (Par);
9169             end loop;
9170
9171             return Par;
9172          end Top_Ancestor;
9173
9174       --  Start of processing for Reset_Entity
9175
9176       begin
9177          N2 := Get_Associated_Node (N);
9178          E := Entity (N2);
9179
9180          if Present (E) then
9181             if Is_Global (E) then
9182                Set_Global_Type (N, N2);
9183
9184             elsif Nkind (N) = N_Op_Concat
9185               and then Is_Generic_Type (Etype (N2))
9186               and then
9187                (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
9188                   or else Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
9189               and then Is_Intrinsic_Subprogram (E)
9190             then
9191                null;
9192
9193             else
9194                --  Entity is local. Mark generic node as unresolved.
9195                --  Note that now it does not have an entity.
9196
9197                Set_Associated_Node (N, Empty);
9198                Set_Etype  (N, Empty);
9199             end if;
9200
9201             if (Nkind (Parent (N)) = N_Package_Instantiation
9202                  or else Nkind (Parent (N)) = N_Function_Instantiation
9203                  or else Nkind (Parent (N)) = N_Procedure_Instantiation)
9204               and then N = Name (Parent (N))
9205             then
9206                Save_Global_Defaults (Parent (N), Parent (N2));
9207             end if;
9208
9209          elsif Nkind (Parent (N)) = N_Selected_Component
9210            and then Nkind (Parent (N2)) = N_Expanded_Name
9211          then
9212
9213             if Is_Global (Entity (Parent (N2))) then
9214                Change_Selected_Component_To_Expanded_Name (Parent (N));
9215                Set_Associated_Node (Parent (N), Parent (N2));
9216                Set_Global_Type (Parent (N), Parent (N2));
9217                Save_Entity_Descendants (N);
9218
9219             --  If this is a reference to the current generic entity,
9220             --  replace by the name of the generic homonym of the current
9221             --  package. This is because in an instantiation  Par.P.Q will
9222             --  not resolve to the name of the instance, whose enclosing
9223             --  scope is not necessarily Par. We use the generic homonym
9224             --  rather that the name of the generic itself, because it may
9225             --  be hidden by a local declaration.
9226
9227             elsif In_Open_Scopes (Entity (Parent (N2)))
9228               and then not
9229                 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2)))))
9230             then
9231                if Ekind (Entity (Parent (N2))) = E_Generic_Package then
9232                   Rewrite (Parent (N),
9233                     Make_Identifier (Sloc (N),
9234                       Chars =>
9235                         Chars (Generic_Homonym (Entity (Parent (N2))))));
9236                else
9237                   Rewrite (Parent (N),
9238                     Make_Identifier (Sloc (N),
9239                       Chars => Chars (Selector_Name (Parent (N2)))));
9240                end if;
9241             end if;
9242
9243             if (Nkind (Parent (Parent (N))) = N_Package_Instantiation
9244                  or else Nkind (Parent (Parent (N)))
9245                    = N_Function_Instantiation
9246                  or else Nkind (Parent (Parent (N)))
9247                    = N_Procedure_Instantiation)
9248               and then Parent (N) = Name (Parent (Parent (N)))
9249             then
9250                Save_Global_Defaults
9251                  (Parent (Parent (N)), Parent (Parent ((N2))));
9252             end if;
9253
9254          --  A selected component may denote a static constant that has
9255          --  been folded. Make the same replacement in original tree.
9256
9257          elsif Nkind (Parent (N)) = N_Selected_Component
9258            and then (Nkind (Parent (N2)) = N_Integer_Literal
9259                       or else Nkind (Parent (N2)) = N_Real_Literal)
9260          then
9261             Rewrite (Parent (N),
9262               New_Copy (Parent (N2)));
9263             Set_Analyzed (Parent (N), False);
9264
9265          --  A selected component may be transformed into a parameterless
9266          --  function call. If the called entity is global, rewrite the
9267          --  node appropriately, i.e. as an extended name for the global
9268          --  entity.
9269
9270          elsif Nkind (Parent (N)) = N_Selected_Component
9271            and then Nkind (Parent (N2)) = N_Function_Call
9272            and then Is_Global (Entity (Name (Parent (N2))))
9273          then
9274             Change_Selected_Component_To_Expanded_Name (Parent (N));
9275             Set_Associated_Node (Parent (N), Name (Parent (N2)));
9276             Set_Global_Type (Parent (N), Name (Parent (N2)));
9277             Save_Entity_Descendants (N);
9278
9279          else
9280             --  Entity is local. Reset in generic unit, so that node
9281             --  is resolved anew at the point of instantiation.
9282
9283             Set_Associated_Node (N, Empty);
9284             Set_Etype (N, Empty);
9285          end if;
9286       end Reset_Entity;
9287
9288       -----------------------------
9289       -- Save_Entity_Descendants --
9290       -----------------------------
9291
9292       procedure Save_Entity_Descendants (N : Node_Id) is
9293       begin
9294          case Nkind (N) is
9295             when N_Binary_Op =>
9296                Save_Global_Descendant (Union_Id (Left_Opnd (N)));
9297                Save_Global_Descendant (Union_Id (Right_Opnd (N)));
9298
9299             when N_Unary_Op =>
9300                Save_Global_Descendant (Union_Id (Right_Opnd (N)));
9301
9302             when N_Expanded_Name | N_Selected_Component =>
9303                Save_Global_Descendant (Union_Id (Prefix (N)));
9304                Save_Global_Descendant (Union_Id (Selector_Name (N)));
9305
9306             when N_Identifier | N_Character_Literal | N_Operator_Symbol =>
9307                null;
9308
9309             when others =>
9310                raise Program_Error;
9311          end case;
9312       end Save_Entity_Descendants;
9313
9314       --------------------------
9315       -- Save_Global_Defaults --
9316       --------------------------
9317
9318       procedure Save_Global_Defaults (N1, N2 : Node_Id) is
9319          Loc    : constant Source_Ptr := Sloc (N1);
9320          Assoc2 : constant List_Id    := Generic_Associations (N2);
9321          Gen_Id : constant Entity_Id  := Get_Generic_Entity (N2);
9322          Assoc1 : List_Id;
9323          Act1   : Node_Id;
9324          Act2   : Node_Id;
9325          Def    : Node_Id;
9326          Ndec   : Node_Id;
9327          Subp   : Entity_Id;
9328          Actual : Entity_Id;
9329
9330       begin
9331          Assoc1 := Generic_Associations (N1);
9332
9333          if Present (Assoc1) then
9334             Act1 := First (Assoc1);
9335          else
9336             Act1 := Empty;
9337             Set_Generic_Associations (N1, New_List);
9338             Assoc1 := Generic_Associations (N1);
9339          end if;
9340
9341          if Present (Assoc2) then
9342             Act2 := First (Assoc2);
9343          else
9344             return;
9345          end if;
9346
9347          while Present (Act1) and then Present (Act2) loop
9348             Next (Act1);
9349             Next (Act2);
9350          end loop;
9351
9352          --  Find the associations added for default suprograms.
9353
9354          if Present (Act2) then
9355             while Nkind (Act2) /= N_Generic_Association
9356               or else No (Entity (Selector_Name (Act2)))
9357               or else not Is_Overloadable (Entity (Selector_Name (Act2)))
9358             loop
9359                Next (Act2);
9360             end loop;
9361
9362             --  Add a similar association if the default is global. The
9363             --  renaming declaration for the actual has been analyzed, and
9364             --  its alias is the program it renames. Link the actual in the
9365             --  original generic tree with the node in the analyzed tree.
9366
9367             while Present (Act2) loop
9368                Subp := Entity (Selector_Name (Act2));
9369                Def  := Explicit_Generic_Actual_Parameter (Act2);
9370
9371                --  Following test is defence against rubbish errors
9372
9373                if No (Alias (Subp)) then
9374                   return;
9375                end if;
9376
9377                --  Retrieve the resolved actual from the renaming declaration
9378                --  created for the instantiated formal.
9379
9380                Actual := Entity (Name (Parent (Parent (Subp))));
9381                Set_Entity (Def, Actual);
9382                Set_Etype (Def, Etype (Actual));
9383
9384                if Is_Global (Actual) then
9385                   Ndec :=
9386                     Make_Generic_Association (Loc,
9387                       Selector_Name => New_Occurrence_Of (Subp, Loc),
9388                         Explicit_Generic_Actual_Parameter =>
9389                           New_Occurrence_Of (Actual, Loc));
9390
9391                   Set_Associated_Node
9392                     (Explicit_Generic_Actual_Parameter (Ndec), Def);
9393
9394                   Append (Ndec, Assoc1);
9395
9396                --  If there are other defaults, add a dummy association
9397                --  in case there are other defaulted formals with the same
9398                --  name.
9399
9400                elsif Present (Next (Act2)) then
9401                   Ndec :=
9402                     Make_Generic_Association (Loc,
9403                       Selector_Name => New_Occurrence_Of (Subp, Loc),
9404                         Explicit_Generic_Actual_Parameter => Empty);
9405
9406                   Append (Ndec, Assoc1);
9407                end if;
9408
9409                Next (Act2);
9410             end loop;
9411          end if;
9412
9413          if Nkind (Name (N1)) = N_Identifier
9414            and then Is_Child_Unit (Gen_Id)
9415            and then Is_Global (Gen_Id)
9416            and then Is_Generic_Unit (Scope (Gen_Id))
9417            and then In_Open_Scopes (Scope (Gen_Id))
9418          then
9419             --  This is an instantiation of a child unit within a sibling,
9420             --  so that the generic parent is in scope. An eventual instance
9421             --  must occur within the scope of an instance of the parent.
9422             --  Make name in instance into an expanded name, to preserve the
9423             --  identifier of the parent, so it can be resolved subsequently.
9424
9425             Rewrite (Name (N2),
9426               Make_Expanded_Name (Loc,
9427                 Chars         => Chars (Gen_Id),
9428                 Prefix        => New_Occurrence_Of (Scope (Gen_Id), Loc),
9429                 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
9430             Set_Entity (Name (N2), Gen_Id);
9431
9432             Rewrite (Name (N1),
9433                Make_Expanded_Name (Loc,
9434                 Chars         => Chars (Gen_Id),
9435                 Prefix        => New_Occurrence_Of (Scope (Gen_Id), Loc),
9436                 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
9437
9438             Set_Associated_Node (Name (N1), Name (N2));
9439             Set_Associated_Node (Prefix (Name (N1)), Empty);
9440             Set_Associated_Node
9441               (Selector_Name (Name (N1)), Selector_Name (Name (N2)));
9442             Set_Etype (Name (N1), Etype (Gen_Id));
9443          end if;
9444
9445       end Save_Global_Defaults;
9446
9447       ----------------------------
9448       -- Save_Global_Descendant --
9449       ----------------------------
9450
9451       procedure Save_Global_Descendant (D : Union_Id) is
9452          N1 : Node_Id;
9453
9454       begin
9455          if D in Node_Range then
9456             if D = Union_Id (Empty) then
9457                null;
9458
9459             elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then
9460                Save_References (Node_Id (D));
9461             end if;
9462
9463          elsif D in List_Range then
9464             if D = Union_Id (No_List)
9465               or else Is_Empty_List (List_Id (D))
9466             then
9467                null;
9468
9469             else
9470                N1 := First (List_Id (D));
9471                while Present (N1) loop
9472                   Save_References (N1);
9473                   Next (N1);
9474                end loop;
9475             end if;
9476
9477          --  Element list or other non-node field, nothing to do
9478
9479          else
9480             null;
9481          end if;
9482       end Save_Global_Descendant;
9483
9484       ---------------------
9485       -- Save_References --
9486       ---------------------
9487
9488       --  This is the recursive procedure that does the work, once the
9489       --  enclosing generic scope has been established. We have to treat
9490       --  specially a number of node rewritings that are required by semantic
9491       --  processing and which change the kind of nodes in the generic copy:
9492       --  typically constant-folding, replacing an operator node by a string
9493       --  literal, or a selected component by an expanded name. In  each of
9494       --  those cases, the transformation is propagated to the generic unit.
9495
9496       procedure Save_References (N : Node_Id) is
9497       begin
9498          if N = Empty then
9499             null;
9500
9501          elsif Nkind (N) = N_Character_Literal
9502            or else Nkind (N) = N_Operator_Symbol
9503          then
9504             if Nkind (N) = Nkind (Get_Associated_Node (N)) then
9505                Reset_Entity (N);
9506
9507             elsif Nkind (N) = N_Operator_Symbol
9508               and then Nkind (Get_Associated_Node (N)) = N_String_Literal
9509             then
9510                Change_Operator_Symbol_To_String_Literal (N);
9511             end if;
9512
9513          elsif Nkind (N) in N_Op then
9514
9515             if Nkind (N) = Nkind (Get_Associated_Node (N)) then
9516
9517                if Nkind (N) = N_Op_Concat then
9518                   Set_Is_Component_Left_Opnd (N,
9519                     Is_Component_Left_Opnd (Get_Associated_Node (N)));
9520
9521                   Set_Is_Component_Right_Opnd (N,
9522                     Is_Component_Right_Opnd (Get_Associated_Node (N)));
9523                end if;
9524
9525                Reset_Entity (N);
9526             else
9527                --  Node may be transformed into call to a user-defined operator
9528
9529                N2 := Get_Associated_Node (N);
9530
9531                if Nkind (N2) = N_Function_Call then
9532                   E := Entity (Name (N2));
9533
9534                   if Present (E)
9535                     and then Is_Global (E)
9536                   then
9537                      Set_Etype (N, Etype (N2));
9538                   else
9539                      Set_Associated_Node (N, Empty);
9540                      Set_Etype (N, Empty);
9541                   end if;
9542
9543                elsif Nkind (N2) = N_Integer_Literal
9544                  or else Nkind (N2) = N_Real_Literal
9545                  or else Nkind (N2) = N_String_Literal
9546                then
9547                   --  Operation was constant-folded, perform the same
9548                   --  replacement in generic.
9549
9550                   Rewrite (N, New_Copy (N2));
9551                   Set_Analyzed (N, False);
9552
9553                elsif Nkind (N2) = N_Identifier
9554                  and then Ekind (Entity (N2)) = E_Enumeration_Literal
9555                then
9556                   --  Same if call was folded into a literal, but in this
9557                   --  case retain the entity to avoid spurious ambiguities
9558                   --  if id is overloaded at the point of instantiation or
9559                   --  inlining.
9560
9561                   Rewrite (N, New_Copy (N2));
9562                   Set_Analyzed (N, False);
9563                end if;
9564             end if;
9565
9566             --  Complete the check on operands, if node has not been
9567             --  constant-folded.
9568
9569             if Nkind (N) in N_Op then
9570                Save_Entity_Descendants (N);
9571             end if;
9572
9573          elsif Nkind (N) = N_Identifier then
9574             if Nkind (N) = Nkind (Get_Associated_Node (N)) then
9575
9576                --  If this is a discriminant reference, always save it.
9577                --  It is used in the instance to find the corresponding
9578                --  discriminant positionally rather than  by name.
9579
9580                Set_Original_Discriminant
9581                  (N, Original_Discriminant (Get_Associated_Node (N)));
9582                Reset_Entity (N);
9583
9584             else
9585                N2 := Get_Associated_Node (N);
9586
9587                if Nkind (N2) = N_Function_Call then
9588                   E := Entity (Name (N2));
9589
9590                   --  Name resolves to a call to parameterless function.
9591                   --  If original entity is global, mark node as resolved.
9592
9593                   if Present (E)
9594                     and then Is_Global (E)
9595                   then
9596                      Set_Etype (N, Etype (N2));
9597                   else
9598                      Set_Associated_Node (N, Empty);
9599                      Set_Etype (N, Empty);
9600                   end if;
9601
9602                elsif
9603                  Nkind (N2) = N_Integer_Literal or else
9604                  Nkind (N2) = N_Real_Literal    or else
9605                  Nkind (N2) = N_String_Literal
9606                then
9607                   --  Name resolves to named number that is constant-folded,
9608                   --  or to string literal from concatenation.
9609                   --  Perform the same replacement in generic.
9610
9611                   Rewrite (N, New_Copy (N2));
9612                   Set_Analyzed (N, False);
9613
9614                elsif Nkind (N2) = N_Explicit_Dereference then
9615
9616                   --  An identifier is rewritten as a dereference if it is
9617                   --  the prefix in a selected component, and it denotes an
9618                   --  access to a composite type, or a parameterless function
9619                   --  call that returns an access type.
9620
9621                   --  Check whether corresponding entity in prefix is global.
9622
9623                   if Is_Entity_Name (Prefix (N2))
9624                     and then Present (Entity (Prefix (N2)))
9625                     and then Is_Global (Entity (Prefix (N2)))
9626                   then
9627                      Rewrite (N,
9628                        Make_Explicit_Dereference (Sloc (N),
9629                           Prefix => Make_Identifier (Sloc (N),
9630                             Chars => Chars (N))));
9631                      Set_Associated_Node (Prefix (N), Prefix (N2));
9632
9633                   elsif Nkind (Prefix (N2)) = N_Function_Call
9634                     and then Is_Global (Entity (Name (Prefix (N2))))
9635                   then
9636                      Rewrite (N,
9637                        Make_Explicit_Dereference (Sloc (N),
9638                           Prefix => Make_Function_Call (Sloc (N),
9639                             Name  =>
9640                               Make_Identifier (Sloc (N),
9641                               Chars => Chars (N)))));
9642
9643                      Set_Associated_Node
9644                       (Name (Prefix (N)), Name (Prefix (N2)));
9645
9646                   else
9647                      Set_Associated_Node (N, Empty);
9648                      Set_Etype (N, Empty);
9649                   end if;
9650
9651                --  The subtype mark of a nominally unconstrained object
9652                --  is rewritten as a subtype indication using the bounds
9653                --  of the expression. Recover the original subtype mark.
9654
9655                elsif Nkind (N2) = N_Subtype_Indication
9656                  and then Is_Entity_Name (Original_Node (N2))
9657                then
9658                   Set_Associated_Node (N, Original_Node (N2));
9659                   Reset_Entity (N);
9660
9661                else
9662                   null;
9663                end if;
9664             end if;
9665
9666          elsif Nkind (N) in N_Entity then
9667             null;
9668
9669          else
9670             declare
9671                use Atree.Unchecked_Access;
9672                --  This code section is part of implementing an untyped tree
9673                --  traversal, so it needs direct access to node fields.
9674
9675             begin
9676                if Nkind (N) = N_Aggregate
9677                     or else
9678                   Nkind (N) = N_Extension_Aggregate
9679                then
9680                   N2 := Get_Associated_Node (N);
9681
9682                   if No (N2)
9683                     or else No (Etype (N2))
9684                     or else not Is_Global (Etype (N2))
9685                   then
9686                      Set_Associated_Node (N, Empty);
9687                   end if;
9688
9689                   Save_Global_Descendant (Field1 (N));
9690                   Save_Global_Descendant (Field2 (N));
9691                   Save_Global_Descendant (Field3 (N));
9692                   Save_Global_Descendant (Field5 (N));
9693
9694                --  All other cases than aggregates
9695
9696                else
9697                   Save_Global_Descendant (Field1 (N));
9698                   Save_Global_Descendant (Field2 (N));
9699                   Save_Global_Descendant (Field3 (N));
9700                   Save_Global_Descendant (Field4 (N));
9701                   Save_Global_Descendant (Field5 (N));
9702                end if;
9703             end;
9704          end if;
9705       end Save_References;
9706
9707    --  Start of processing for Save_Global_References
9708
9709    begin
9710       Gen_Scope := Current_Scope;
9711
9712       --  If the generic unit is a child unit, references to entities in
9713       --  the parent are treated as local, because they will be resolved
9714       --  anew in the context of the instance of the parent.
9715
9716       while Is_Child_Unit (Gen_Scope)
9717         and then Ekind (Scope (Gen_Scope)) = E_Generic_Package
9718       loop
9719          Gen_Scope := Scope (Gen_Scope);
9720       end loop;
9721
9722       Save_References (N);
9723    end Save_Global_References;
9724
9725    --------------------------------------
9726    -- Set_Copied_Sloc_For_Inlined_Body --
9727    --------------------------------------
9728
9729    procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
9730    begin
9731       Create_Instantiation_Source (N, E, True, S_Adjustment);
9732    end Set_Copied_Sloc_For_Inlined_Body;
9733
9734    ---------------------
9735    -- Set_Instance_Of --
9736    ---------------------
9737
9738    procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is
9739    begin
9740       Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null);
9741       Generic_Renamings_HTable.Set (Generic_Renamings.Last);
9742       Generic_Renamings.Increment_Last;
9743    end Set_Instance_Of;
9744
9745    --------------------
9746    -- Set_Next_Assoc --
9747    --------------------
9748
9749    procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is
9750    begin
9751       Generic_Renamings.Table (E).Next_In_HTable := Next;
9752    end Set_Next_Assoc;
9753
9754    -------------------
9755    -- Start_Generic --
9756    -------------------
9757
9758    procedure Start_Generic is
9759    begin
9760       --  ??? I am sure more things could be factored out in this
9761       --  routine. Should probably be done at a later stage.
9762
9763       Generic_Flags.Increment_Last;
9764       Generic_Flags.Table (Generic_Flags.Last) := Inside_A_Generic;
9765       Inside_A_Generic := True;
9766
9767       Expander_Mode_Save_And_Set (False);
9768    end Start_Generic;
9769
9770    ----------------------
9771    -- Set_Instance_Env --
9772    ----------------------
9773
9774    procedure Set_Instance_Env
9775      (Gen_Unit : Entity_Id;
9776       Act_Unit : Entity_Id)
9777    is
9778
9779    begin
9780       --  Regardless of the current mode, predefined units are analyzed in
9781       --  the most current Ada mode, and earlier version Ada checks do not
9782       --  apply to predefined units.
9783
9784       if Is_Internal_File_Name
9785           (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
9786            Renamings_Included => True) then
9787          Ada_Version := Ada_Version_Type'Last;
9788       end if;
9789
9790       Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
9791    end Set_Instance_Env;
9792
9793    -----------------
9794    -- Switch_View --
9795    -----------------
9796
9797    procedure Switch_View (T : Entity_Id) is
9798       BT        : constant Entity_Id := Base_Type (T);
9799       Priv_Elmt : Elmt_Id := No_Elmt;
9800       Priv_Sub  : Entity_Id;
9801
9802    begin
9803       --  T may be private but its base type may have been exchanged through
9804       --  some other occurrence, in which case there is nothing to switch.
9805
9806       if not Is_Private_Type (BT) then
9807          return;
9808       end if;
9809
9810       Priv_Elmt := First_Elmt (Private_Dependents (BT));
9811
9812       if Present (Full_View (BT)) then
9813          Append_Elmt (Full_View (BT), Exchanged_Views);
9814          Exchange_Declarations (BT);
9815       end if;
9816
9817       while Present (Priv_Elmt) loop
9818          Priv_Sub := (Node (Priv_Elmt));
9819
9820          --  We avoid flipping the subtype if the Etype of its full
9821          --  view is private because this would result in a malformed
9822          --  subtype. This occurs when the Etype of the subtype full
9823          --  view is the full view of the base type (and since the
9824          --  base types were just switched, the subtype is pointing
9825          --  to the wrong view). This is currently the case for
9826          --  tagged record types, access types (maybe more?) and
9827          --  needs to be resolved. ???
9828
9829          if Present (Full_View (Priv_Sub))
9830            and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
9831          then
9832             Append_Elmt (Full_View (Priv_Sub), Exchanged_Views);
9833             Exchange_Declarations (Priv_Sub);
9834          end if;
9835
9836          Next_Elmt (Priv_Elmt);
9837       end loop;
9838    end Switch_View;
9839
9840    -----------------------------
9841    -- Valid_Default_Attribute --
9842    -----------------------------
9843
9844    procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
9845       Attr_Id : constant Attribute_Id :=
9846                   Get_Attribute_Id (Attribute_Name (Def));
9847       T       : constant Entity_Id := Entity (Prefix (Def));
9848       Is_Fun  : constant Boolean := (Ekind (Nam) = E_Function);
9849       F       : Entity_Id;
9850       Num_F   : Int;
9851       OK      : Boolean;
9852
9853    begin
9854       if No (T)
9855         or else T = Any_Id
9856       then
9857          return;
9858       end if;
9859
9860       Num_F := 0;
9861       F := First_Formal (Nam);
9862       while Present (F) loop
9863          Num_F := Num_F + 1;
9864          Next_Formal (F);
9865       end loop;
9866
9867       case Attr_Id is
9868          when Attribute_Adjacent |  Attribute_Ceiling   | Attribute_Copy_Sign |
9869               Attribute_Floor    |  Attribute_Fraction  | Attribute_Machine   |
9870               Attribute_Model    |  Attribute_Remainder | Attribute_Rounding  |
9871               Attribute_Unbiased_Rounding  =>
9872             OK := Is_Fun
9873                     and then Num_F = 1
9874                     and then Is_Floating_Point_Type (T);
9875
9876          when Attribute_Image    | Attribute_Pred       | Attribute_Succ |
9877               Attribute_Value    | Attribute_Wide_Image |
9878               Attribute_Wide_Value  =>
9879             OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
9880
9881          when Attribute_Max      |  Attribute_Min  =>
9882             OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
9883
9884          when Attribute_Input =>
9885             OK := (Is_Fun and then Num_F = 1);
9886
9887          when Attribute_Output | Attribute_Read | Attribute_Write =>
9888             OK := (not Is_Fun and then Num_F = 2);
9889
9890          when others =>
9891             OK := False;
9892       end case;
9893
9894       if not OK then
9895          Error_Msg_N ("attribute reference has wrong profile for subprogram",
9896            Def);
9897       end if;
9898    end Valid_Default_Attribute;
9899
9900 end Sem_Ch12;