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