gcc/ada/sem_ch10.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ C H 1 0                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Exp_Util; use Exp_Util;
  32 with Fname;    use Fname;
  33 with Fname.UF; use Fname.UF;
  34 with Freeze;   use Freeze;
  35 with Impunit;  use Impunit;
  36 with Inline;   use Inline;
  37 with Lib;      use Lib;
  38 with Lib.Load; use Lib.Load;
  39 with Lib.Xref; use Lib.Xref;
  40 with Namet;    use Namet;
  41 with Nlists;   use Nlists;
  42 with Nmake;    use Nmake;
  43 with Opt;      use Opt;
  44 with Output;   use Output;
  45 with Restrict; use Restrict;
  46 with Rtsfind;  use Rtsfind;
  47 with Sem;      use Sem;
  48 with Sem_Ch6;  use Sem_Ch6;
  49 with Sem_Ch7;  use Sem_Ch7;
  50 with Sem_Ch8;  use Sem_Ch8;
  51 with Sem_Dist; use Sem_Dist;
  52 with Sem_Prag; use Sem_Prag;
  53 with Sem_Util; use Sem_Util;
  54 with Sem_Warn; use Sem_Warn;
  55 with Stand;    use Stand;
  56 with Sinfo;    use Sinfo;
  57 with Sinfo.CN; use Sinfo.CN;
  58 with Sinput;   use Sinput;
  59 with Snames;   use Snames;
  60 with Style;    use Style;
  61 with Stylesw;  use Stylesw;
  62 with Tbuild;   use Tbuild;
  63 with Ttypes;   use Ttypes;
  64 with Uname;    use Uname;
  65
  66 package body Sem_Ch10 is
  67
  68    -----------------------
  69    -- Local Subprograms --
  70    -----------------------
  71
  72    procedure Analyze_Context (N : Node_Id);
  73    --  Analyzes items in the context clause of compilation unit
  74
  75    procedure Build_Limited_Views (N : Node_Id);
  76    --  Build and decorate the list of shadow entities for a package mentioned
  77    --  in a limited_with clause. If the package was not previously analyzed
  78    --  then it also performs a basic decoration of the real entities; this
  79    --  is required to do not pass non-decorated entities to the back-end.
  80    --  Implements Ada 2005 (AI-50217).
  81
  82    procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
  83    --  Check whether the source for the body of a compilation unit must
  84    --  be included in a standalone library.
  85
  86    procedure Check_With_Type_Clauses (N : Node_Id);
  87    --  If N is a body, verify that any with_type clauses on the spec, or
  88    --  on the spec of any parent, have a matching with_clause.
  89
  90    procedure Check_Private_Child_Unit (N : Node_Id);
  91    --  If a with_clause mentions a private child unit, the compilation
  92    --  unit must be a member of the same family, as described in 10.1.2 (8).
  93
  94    procedure Check_Stub_Level (N : Node_Id);
  95    --  Verify that a stub is declared immediately within a compilation unit,
  96    --  and not in an inner frame.
  97
  98    procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id);
  99    --  When a child unit appears in a context clause, the implicit withs on
 100    --  parents are made explicit, and with clauses are inserted in the context
 101    --  clause before the one for the child. If a parent in the with_clause
 102    --  is a renaming, the implicit with_clause is on the renaming whose name
 103    --  is mentioned in the with_clause, and not on the package it renames.
 104    --  N is the compilation unit whose list of context items receives the
 105    --  implicit with_clauses.
 106
 107    function Get_Parent_Entity (Unit : Node_Id) return Entity_Id;
 108    --  Get defining entity of parent unit of a child unit. In most cases this
 109    --  is the defining entity of the unit, but for a child instance whose
 110    --  parent needs a body for inlining, the instantiation node of the parent
 111    --  has not yet been rewritten as a package declaration, and the entity has
 112    --  to be retrieved from the Instance_Spec of the unit.
 113
 114    procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
 115    --  If the main unit is a child unit, implicit withs are also added for
 116    --  all its ancestors.
 117
 118    function In_Chain (E : Entity_Id) return Boolean;
 119    --  Check that the shadow entity is not already in the homonym chain, for
 120    --  example through a limited_with clause in a parent unit.
 121
 122    procedure Install_Context_Clauses (N : Node_Id);
 123    --  Subsidiary to Install_Context and Install_Parents. Process only with_
 124    --  and use_clauses for current unit and its library unit if any.
 125
 126    procedure Install_Limited_Context_Clauses (N : Node_Id);
 127    --  Subsidiary to Install_Context. Process only limited with_clauses
 128    --  for current unit. Implements Ada 2005 (AI-50217).
 129
 130    procedure Install_Limited_Withed_Unit (N : Node_Id);
 131    --  Place shadow entities for a limited_with package in the visibility
 132    --  structures for the current compilation. Implements Ada 2005 (AI-50217).
 133
 134    procedure Install_Withed_Unit
 135      (With_Clause     : Node_Id;
 136       Private_With_OK : Boolean := False);
 137    --  If the unit is not a child unit, make unit immediately visible.
 138    --  The caller ensures that the unit is not already currently installed.
 139    --  The flag Private_With_OK is set true in Install_Private_With_Clauses,
 140    --  which is called when compiling the private part of a package, or
 141    --  installing the private declarations of a parent unit.
 142
 143    procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
 144    --  This procedure establishes the context for the compilation of a child
 145    --  unit. If Lib_Unit is a child library spec then the context of the parent
 146    --  is installed, and the parent itself made immediately visible, so that
 147    --  the child unit is processed in the declarative region of the parent.
 148    --  Install_Parents makes a recursive call to itself to ensure that all
 149    --  parents are loaded in the nested case. If Lib_Unit is a library body,
 150    --  the only effect of Install_Parents is to install the private decls of
 151    --  the parents, because the visible parent declarations will have been
 152    --  installed as part of the context of the corresponding spec.
 153
 154    procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id);
 155    --  In the compilation of a child unit, a child of any of the  ancestor
 156    --  units is directly visible if it is visible, because the parent is in
 157    --  an enclosing scope. Iterate over context to find child units of U_Name
 158    --  or of some ancestor of it.
 159
 160    function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
 161    --  Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
 162    --  returns True if Lib_Unit is a library spec which is a child spec, i.e.
 163    --  a library spec that has a parent. If the call to Is_Child_Spec returns
 164    --  True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
 165    --  compilation unit for the parent spec.
 166    --
 167    --  Lib_Unit can also be a subprogram body that acts as its own spec. If
 168    --  the Parent_Spec is  non-empty, this is also a child unit.
 169
 170    procedure Remove_With_Type_Clause (Name : Node_Id);
 171    --  Remove imported type and its enclosing package from visibility, and
 172    --  remove attributes of imported type so they don't interfere with its
 173    --  analysis (should it appear otherwise in the context).
 174
 175    procedure Remove_Context_Clauses (N : Node_Id);
 176    --  Subsidiary of previous one. Remove use_ and with_clauses
 177
 178    procedure Remove_Limited_With_Clause (N : Node_Id);
 179    --  Remove from visibility the shadow entities introduced for a package
 180    --  mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
 181
 182    procedure Remove_Parents (Lib_Unit : Node_Id);
 183    --  Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
 184    --  contexts established by the corresponding call to Install_Parents are
 185    --  removed. Remove_Parents contains a recursive call to itself to ensure
 186    --  that all parents are removed in the nested case.
 187
 188    procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
 189    --  Reset all visibility flags on unit after compiling it, either as a
 190    --  main unit or as a unit in the context.
 191
 192    procedure Unchain (E : Entity_Id);
 193    --  Remove single entity from visibility list
 194
 195    procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
 196    --  Common processing for all stubs (subprograms, tasks, packages, and
 197    --  protected cases). N is the stub to be analyzed. Once the subunit
 198    --  name is established, load and analyze. Nam is the non-overloadable
 199    --  entity for which the proper body provides a completion. Subprogram
 200    --  stubs are handled differently because they can be declarations.
 201
 202    --------------------------
 203    -- Limited_With_Clauses --
 204    --------------------------
 205
 206    --  Limited_With clauses are the mechanism chosen for Ada05 to support
 207    --  mutually recursive types declared in different units. A limited_with
 208    --  clause that names package P in the context of unit U makes the types
 209    --  declared in the visible part of P available within U, but with the
 210    --  restriction that these types can only be used as incomplete types.
 211    --  The limited_with clause does not impose a semantic dependence on P,
 212    --  and it is possible for two packages to have limited_with_clauses on
 213    --  each other without creating an elaboration circularity.
 214
 215    --  To support this feature, the analysis of a limited_with clause must
 216    --  create an abbreviated view of the package, without performing any
 217    --  semantic analysis on it. This "package abstract" contains shadow
 218    --  types that are in one-one correspondence with the real types in the
 219    --  package, and that have the properties of incomplete types.
 220
 221    --  The implementation creates two element lists: one to chain the shadow
 222    --  entities, and one to chain the corresponding type entities in the tree
 223    --  of the package. Links between corresponding entities in both chains
 224    --  allow the compiler to select the proper view of a given type, depending
 225    --  on the context. Note that in contrast with the handling of private
 226    --  types, the limited view and the non-limited view of a type are treated
 227    --  as separate entities, and no entity exchange needs to take place, which
 228    --  makes the implementation must simpler than could be feared.
 229
 230    ------------------------------
 231    -- Analyze_Compilation_Unit --
 232    ------------------------------
 233
 234    procedure Analyze_Compilation_Unit (N : Node_Id) is
 235       Unit_Node     : constant Node_Id := Unit (N);
 236       Lib_Unit      : Node_Id          := Library_Unit (N);
 237       Spec_Id       : Node_Id;
 238       Main_Cunit    : constant Node_Id := Cunit (Main_Unit);
 239       Par_Spec_Name : Unit_Name_Type;
 240       Unum          : Unit_Number_Type;
 241
 242       procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
 243       --  Generate cross-reference information for the parents of child units.
 244       --  N is a defining_program_unit_name, and P_Id is the immediate parent.
 245
 246       --------------------------------
 247       -- Generate_Parent_References --
 248       --------------------------------
 249
 250       procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
 251          Pref   : Node_Id;
 252          P_Name : Entity_Id := P_Id;
 253
 254       begin
 255          Pref   := Name (Parent (Defining_Entity (N)));
 256
 257          if Nkind (Pref) = N_Expanded_Name then
 258
 259             --  Done already, if the unit has been compiled indirectly as
 260             --  part of the closure of its context because of inlining.
 261
 262             return;
 263          end if;
 264
 265          while Nkind (Pref) = N_Selected_Component loop
 266             Change_Selected_Component_To_Expanded_Name (Pref);
 267             Set_Entity (Pref, P_Name);
 268             Set_Etype (Pref, Etype (P_Name));
 269             Generate_Reference (P_Name, Pref, 'r');
 270             Pref   := Prefix (Pref);
 271             P_Name := Scope (P_Name);
 272          end loop;
 273
 274          --  The guard here on P_Name is to handle the error condition where
 275          --  the parent unit is missing because the file was not found.
 276
 277          if Present (P_Name) then
 278             Set_Entity (Pref, P_Name);
 279             Set_Etype (Pref, Etype (P_Name));
 280             Generate_Reference (P_Name, Pref, 'r');
 281             Style.Check_Identifier (Pref, P_Name);
 282          end if;
 283       end Generate_Parent_References;
 284
 285    --  Start of processing for Analyze_Compilation_Unit
 286
 287    begin
 288       Process_Compilation_Unit_Pragmas (N);
 289
 290       --  If the unit is a subunit whose parent has not been analyzed (which
 291       --  indicates that the main unit is a subunit, either the current one or
 292       --  one of its descendents) then the subunit is compiled as part of the
 293       --  analysis of the parent, which we proceed to do. Basically this gets
 294       --  handled from the top down and we don't want to do anything at this
 295       --  level (i.e. this subunit will be handled on the way down from the
 296       --  parent), so at this level we immediately return. If the subunit
 297       --  ends up not analyzed, it means that the parent did not contain a
 298       --  stub for it, or that there errors were dectected in some ancestor.
 299
 300       if Nkind (Unit_Node) = N_Subunit
 301         and then not Analyzed (Lib_Unit)
 302       then
 303          Semantics (Lib_Unit);
 304
 305          if not Analyzed (Proper_Body (Unit_Node)) then
 306             if Serious_Errors_Detected > 0 then
 307                Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
 308             else
 309                Error_Msg_N ("missing stub for subunit", N);
 310             end if;
 311          end if;
 312
 313          return;
 314       end if;
 315
 316       --  Analyze context (this will call Sem recursively for with'ed units)
 317
 318       Analyze_Context (N);
 319
 320       --  If the unit is a package body, the spec is already loaded and must
 321       --  be analyzed first, before we analyze the body.
 322
 323       if Nkind (Unit_Node) = N_Package_Body then
 324
 325          --  If no Lib_Unit, then there was a serious previous error, so
 326          --  just ignore the entire analysis effort
 327
 328          if No (Lib_Unit) then
 329             return;
 330
 331          else
 332             Semantics (Lib_Unit);
 333             Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
 334
 335             --  Verify that the library unit is a package declaration
 336
 337             if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration
 338                  and then
 339                Nkind (Unit (Lib_Unit)) /= N_Generic_Package_Declaration
 340             then
 341                Error_Msg_N
 342                  ("no legal package declaration for package body", N);
 343                return;
 344
 345             --  Otherwise, the entity in the declaration is visible. Update
 346             --  the version to reflect dependence of this body on the spec.
 347
 348             else
 349                Spec_Id := Defining_Entity (Unit (Lib_Unit));
 350                Set_Is_Immediately_Visible (Spec_Id, True);
 351                Version_Update (N, Lib_Unit);
 352
 353                if Nkind (Defining_Unit_Name (Unit_Node))
 354                  = N_Defining_Program_Unit_Name
 355                then
 356                   Generate_Parent_References (Unit_Node, Scope (Spec_Id));
 357                end if;
 358             end if;
 359          end if;
 360
 361       --  If the unit is a subprogram body, then we similarly need to analyze
 362       --  its spec. However, things are a little simpler in this case, because
 363       --  here, this analysis is done only for error checking and consistency
 364       --  purposes, so there's nothing else to be done.
 365
 366       elsif Nkind (Unit_Node) = N_Subprogram_Body then
 367          if Acts_As_Spec (N) then
 368
 369             --  If the subprogram body is a child unit, we must create a
 370             --  declaration for it, in order to properly load the parent(s).
 371             --  After this, the original unit does not acts as a spec, because
 372             --  there is an explicit one. If this  unit appears in a context
 373             --  clause, then an implicit with on the parent will be added when
 374             --  installing the context. If this is the main unit, there is no
 375             --  Unit_Table entry for the declaration, (It has the unit number
 376             --  of the main unit) and code generation is unaffected.
 377
 378             Unum := Get_Cunit_Unit_Number (N);
 379             Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
 380
 381             if Par_Spec_Name /= No_Name then
 382                Unum :=
 383                  Load_Unit
 384                    (Load_Name  => Par_Spec_Name,
 385                     Required   => True,
 386                     Subunit    => False,
 387                     Error_Node => N);
 388
 389                if Unum /= No_Unit then
 390
 391                   --  Build subprogram declaration and attach parent unit to it
 392                   --  This subprogram declaration does not come from source,
 393                   --  Nevertheless the backend must generate debugging info for
 394                   --  it, and this must be indicated explicitly.
 395
 396                   declare
 397                      Loc : constant Source_Ptr := Sloc (N);
 398                      SCS : constant Boolean :=
 399                              Get_Comes_From_Source_Default;
 400
 401                   begin
 402                      Set_Comes_From_Source_Default (False);
 403                      Lib_Unit :=
 404                        Make_Compilation_Unit (Loc,
 405                          Context_Items => New_Copy_List (Context_Items (N)),
 406                          Unit =>
 407                            Make_Subprogram_Declaration (Sloc (N),
 408                              Specification =>
 409                                Copy_Separate_Tree
 410                                  (Specification (Unit_Node))),
 411                          Aux_Decls_Node =>
 412                            Make_Compilation_Unit_Aux (Loc));
 413
 414                      Set_Library_Unit (N, Lib_Unit);
 415                      Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
 416                      Semantics (Lib_Unit);
 417                      Set_Acts_As_Spec (N, False);
 418                      Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit)));
 419                      Set_Comes_From_Source_Default (SCS);
 420                   end;
 421                end if;
 422             end if;
 423
 424          --  Here for subprogram with separate declaration
 425
 426          else
 427             Semantics (Lib_Unit);
 428             Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
 429             Version_Update (N, Lib_Unit);
 430          end if;
 431
 432          if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
 433                                              N_Defining_Program_Unit_Name
 434          then
 435             Generate_Parent_References (
 436               Specification (Unit_Node),
 437                 Scope (Defining_Entity (Unit (Lib_Unit))));
 438          end if;
 439       end if;
 440
 441       --  If it is a child unit, the parent must be elaborated first
 442       --  and we update version, since we are dependent on our parent.
 443
 444       if Is_Child_Spec (Unit_Node) then
 445
 446          --  The analysis of the parent is done with style checks off
 447
 448          declare
 449             Save_Style_Check : constant Boolean := Style_Check;
 450             Save_C_Restrict  : constant Save_Cunit_Boolean_Restrictions :=
 451                                  Cunit_Boolean_Restrictions_Save;
 452
 453          begin
 454             if not GNAT_Mode then
 455                Style_Check := False;
 456             end if;
 457
 458             Semantics (Parent_Spec (Unit_Node));
 459             Version_Update (N, Parent_Spec (Unit_Node));
 460             Style_Check := Save_Style_Check;
 461             Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
 462          end;
 463       end if;
 464
 465       --  With the analysis done, install the context. Note that we can't
 466       --  install the context from the with clauses as we analyze them,
 467       --  because each with clause must be analyzed in a clean visibility
 468       --  context, so we have to wait and install them all at once.
 469
 470       Install_Context (N);
 471
 472       if Is_Child_Spec (Unit_Node) then
 473
 474          --  Set the entities of all parents in the program_unit_name
 475
 476          Generate_Parent_References (
 477            Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node))));
 478       end if;
 479
 480       --  All components of the context: with-clauses, library unit, ancestors
 481       --  if any, (and their context)  are analyzed and installed. Now analyze
 482       --  the unit itself, which is either a package, subprogram spec or body.
 483
 484       Analyze (Unit_Node);
 485
 486       --  The above call might have made Unit_Node an N_Subprogram_Body
 487       --  from something else, so propagate any Acts_As_Spec flag.
 488
 489       if Nkind (Unit_Node) = N_Subprogram_Body
 490         and then Acts_As_Spec (Unit_Node)
 491       then
 492          Set_Acts_As_Spec (N);
 493       end if;
 494
 495       --  Register predefined units in Rtsfind
 496
 497       declare
 498          Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N));
 499       begin
 500          if Is_Predefined_File_Name (Unit_File_Name (Unum)) then
 501             Set_RTU_Loaded (Unit_Node);
 502          end if;
 503       end;
 504
 505       --  Treat compilation unit pragmas that appear after the library unit
 506
 507       if Present (Pragmas_After (Aux_Decls_Node (N))) then
 508          declare
 509             Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
 510
 511          begin
 512             while Present (Prag_Node) loop
 513                Analyze (Prag_Node);
 514                Next (Prag_Node);
 515             end loop;
 516          end;
 517       end if;
 518
 519       --  Generate distribution stubs if requested and no error
 520
 521       if N = Main_Cunit
 522         and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
 523                     or else
 524                   Distribution_Stub_Mode = Generate_Caller_Stub_Body)
 525         and then not Fatal_Error (Main_Unit)
 526       then
 527          if Is_RCI_Pkg_Spec_Or_Body (N) then
 528
 529             --  Regular RCI package
 530
 531             Add_Stub_Constructs (N);
 532
 533          elsif (Nkind (Unit_Node) = N_Package_Declaration
 534                  and then Is_Shared_Passive (Defining_Entity
 535                                               (Specification (Unit_Node))))
 536            or else (Nkind (Unit_Node) = N_Package_Body
 537                      and then
 538                        Is_Shared_Passive (Corresponding_Spec (Unit_Node)))
 539          then
 540             --  Shared passive package
 541
 542             Add_Stub_Constructs (N);
 543
 544          elsif Nkind (Unit_Node) = N_Package_Instantiation
 545            and then
 546              Is_Remote_Call_Interface
 547                (Defining_Entity (Specification (Instance_Spec (Unit_Node))))
 548          then
 549             --  Instantiation of a RCI generic package
 550
 551             Add_Stub_Constructs (N);
 552          end if;
 553
 554       end if;
 555
 556       if Nkind (Unit_Node) = N_Package_Declaration
 557         or else Nkind (Unit_Node) in N_Generic_Declaration
 558         or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
 559         or else Nkind (Unit_Node) = N_Subprogram_Declaration
 560       then
 561          Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
 562
 563       --  If the unit is an instantiation whose body will be elaborated
 564       --  for inlining purposes, use the the proper entity of the instance.
 565
 566       elsif Nkind (Unit_Node) = N_Package_Instantiation
 567         and then not Error_Posted (Unit_Node)
 568       then
 569          Remove_Unit_From_Visibility
 570            (Defining_Entity (Instance_Spec (Unit_Node)));
 571
 572       elsif Nkind (Unit_Node) = N_Package_Body
 573         or else (Nkind (Unit_Node) = N_Subprogram_Body
 574                   and then not Acts_As_Spec (Unit_Node))
 575       then
 576          --  Bodies that are not the main unit are compiled if they
 577          --  are generic or contain generic or inlined units. Their
 578          --  analysis brings in the context of the corresponding spec
 579          --  (unit declaration) which must be removed as well, to
 580          --  return the compilation environment to its proper state.
 581
 582          Remove_Context (Lib_Unit);
 583          Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
 584       end if;
 585
 586       --  Last step is to deinstall the context we just installed
 587       --  as well as the unit just compiled.
 588
 589       Remove_Context (N);
 590
 591       --  If this is the main unit and we are generating code, we must
 592       --  check that all generic units in the context have a body if they
 593       --  need it, even if they have not been instantiated. In the absence
 594       --  of .ali files for generic units, we must force the load of the body,
 595       --  just to produce the proper error if the body is absent. We skip this
 596       --  verification if the main unit itself is generic.
 597
 598       if Get_Cunit_Unit_Number (N) = Main_Unit
 599         and then Operating_Mode = Generate_Code
 600         and then Expander_Active
 601       then
 602          --  Check whether the source for the body of the unit must be
 603          --  included in a standalone library.
 604
 605          Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit));
 606
 607          --  Indicate that the main unit is now analyzed, to catch possible
 608          --  circularities between it and generic bodies. Remove main unit
 609          --  from visibility. This might seem superfluous, but the main unit
 610          --  must not be visible in the generic body expansions that follow.
 611
 612          Set_Analyzed (N, True);
 613          Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
 614
 615          declare
 616             Item  : Node_Id;
 617             Nam   : Entity_Id;
 618             Un    : Unit_Number_Type;
 619
 620             Save_Style_Check : constant Boolean := Style_Check;
 621             Save_C_Restrict  : constant Save_Cunit_Boolean_Restrictions :=
 622                                  Cunit_Boolean_Restrictions_Save;
 623
 624          begin
 625             Item := First (Context_Items (N));
 626             while Present (Item) loop
 627
 628                --  Ada 2005 (AI-50217): Do not consider limited-withed units
 629
 630                if Nkind (Item) = N_With_Clause
 631                   and then not Implicit_With (Item)
 632                   and then not Limited_Present (Item)
 633                then
 634                   Nam := Entity (Name (Item));
 635
 636                   if (Is_Generic_Subprogram (Nam)
 637                        and then not Is_Intrinsic_Subprogram (Nam))
 638                     or else (Ekind (Nam) = E_Generic_Package
 639                               and then Unit_Requires_Body (Nam))
 640                   then
 641                      Style_Check := False;
 642
 643                      if Present (Renamed_Object (Nam)) then
 644                         Un :=
 645                            Load_Unit
 646                              (Load_Name  => Get_Body_Name
 647                                               (Get_Unit_Name
 648                                                 (Unit_Declaration_Node
 649                                                   (Renamed_Object (Nam)))),
 650                               Required   => False,
 651                               Subunit    => False,
 652                               Error_Node => N,
 653                               Renamings  => True);
 654                      else
 655                         Un :=
 656                           Load_Unit
 657                             (Load_Name  => Get_Body_Name
 658                                              (Get_Unit_Name (Item)),
 659                              Required   => False,
 660                              Subunit    => False,
 661                              Error_Node => N,
 662                              Renamings  => True);
 663                      end if;
 664
 665                      if Un = No_Unit then
 666                         Error_Msg_NE
 667                           ("body of generic unit& not found", Item, Nam);
 668                         exit;
 669
 670                      elsif not Analyzed (Cunit (Un))
 671                        and then Un /= Main_Unit
 672                        and then not Fatal_Error (Un)
 673                      then
 674                         Style_Check := False;
 675                         Semantics (Cunit (Un));
 676                      end if;
 677                   end if;
 678                end if;
 679
 680                Next (Item);
 681             end loop;
 682
 683             Style_Check := Save_Style_Check;
 684             Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
 685          end;
 686       end if;
 687
 688       --  Deal with creating elaboration Boolean if needed. We create an
 689       --  elaboration boolean only for units that come from source since
 690       --  units manufactured by the compiler never need elab checks.
 691
 692       if Comes_From_Source (N)
 693         and then
 694           (Nkind (Unit (N)) =  N_Package_Declaration         or else
 695            Nkind (Unit (N)) =  N_Generic_Package_Declaration or else
 696            Nkind (Unit (N)) =  N_Subprogram_Declaration      or else
 697            Nkind (Unit (N)) =  N_Generic_Subprogram_Declaration)
 698       then
 699          declare
 700             Loc  : constant Source_Ptr := Sloc (N);
 701             Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
 702
 703          begin
 704             Spec_Id := Defining_Entity (Unit (N));
 705             Generate_Definition (Spec_Id);
 706
 707             --  See if an elaboration entity is required for possible
 708             --  access before elaboration checking. Note that we must
 709             --  allow for this even if -gnatE is not set, since a client
 710             --  may be compiled in -gnatE mode and reference the entity.
 711
 712             --  Case of units which do not require elaboration checks
 713
 714             if
 715                --  Pure units do not need checks
 716
 717                  Is_Pure (Spec_Id)
 718
 719                --  Preelaborated units do not need checks
 720
 721                  or else Is_Preelaborated (Spec_Id)
 722
 723                --  No checks needed if pagma Elaborate_Body present
 724
 725                  or else Has_Pragma_Elaborate_Body (Spec_Id)
 726
 727                --  No checks needed if unit does not require a body
 728
 729                  or else not Unit_Requires_Body (Spec_Id)
 730
 731                --  No checks needed for predefined files
 732
 733                  or else Is_Predefined_File_Name (Unit_File_Name (Unum))
 734
 735                --  No checks required if no separate spec
 736
 737                  or else Acts_As_Spec (N)
 738             then
 739                --  This is a case where we only need the entity for
 740                --  checking to prevent multiple elaboration checks.
 741
 742                Set_Elaboration_Entity_Required (Spec_Id, False);
 743
 744             --  Case of elaboration entity is required for access before
 745             --  elaboration checking (so certainly we must build it!)
 746
 747             else
 748                Set_Elaboration_Entity_Required (Spec_Id, True);
 749             end if;
 750
 751             Build_Elaboration_Entity (N, Spec_Id);
 752          end;
 753       end if;
 754
 755       --  Finally, freeze the compilation unit entity. This for sure is needed
 756       --  because of some warnings that can be output (see Freeze_Subprogram),
 757       --  but may in general be required. If freezing actions result, place
 758       --  them in the compilation unit actions list, and analyze them.
 759
 760       declare
 761          Loc : constant Source_Ptr := Sloc (N);
 762          L   : constant List_Id :=
 763                  Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
 764
 765       begin
 766          while Is_Non_Empty_List (L) loop
 767             Insert_Library_Level_Action (Remove_Head (L));
 768          end loop;
 769       end;
 770
 771       Set_Analyzed (N);
 772
 773       if Nkind (Unit_Node) = N_Package_Declaration
 774         and then Get_Cunit_Unit_Number (N) /= Main_Unit
 775         and then Expander_Active
 776       then
 777          declare
 778             Save_Style_Check : constant Boolean := Style_Check;
 779             Save_Warning     : constant Warning_Mode_Type := Warning_Mode;
 780             Options          : Style_Check_Options;
 781
 782          begin
 783             Save_Style_Check_Options (Options);
 784             Reset_Style_Check_Options;
 785             Opt.Warning_Mode := Suppress;
 786             Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
 787
 788             Reset_Style_Check_Options;
 789             Set_Style_Check_Options (Options);
 790             Style_Check := Save_Style_Check;
 791             Warning_Mode := Save_Warning;
 792          end;
 793       end if;
 794    end Analyze_Compilation_Unit;
 795
 796    ---------------------
 797    -- Analyze_Context --
 798    ---------------------
 799
 800    procedure Analyze_Context (N : Node_Id) is
 801       Ukind : constant Node_Kind := Nkind (Unit (N));
 802       Item  : Node_Id;
 803
 804    begin
 805       --  Loop through context items. This is done in two:
 806       --  a) The first  pass analyzes non-limited with-clauses
 807       --  b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217)
 808
 809       Item := First (Context_Items (N));
 810       while Present (Item) loop
 811
 812          --  For with clause, analyze the with clause, and then update
 813          --  the version, since we are dependent on a unit that we with.
 814
 815          if Nkind (Item) = N_With_Clause
 816            and then not Limited_Present (Item)
 817          then
 818             --  Skip analyzing with clause if no unit, nothing to do (this
 819             --  happens for a with that references a non-existant unit)
 820
 821             if Present (Library_Unit (Item)) then
 822                Analyze (Item);
 823             end if;
 824
 825             if not Implicit_With (Item) then
 826                Version_Update (N, Library_Unit (Item));
 827             end if;
 828
 829          --  But skip use clauses at this stage, since we don't want to do
 830          --  any installing of potentially use visible entities until we
 831          --  we actually install the complete context (in Install_Context).
 832          --  Otherwise things can get installed in the wrong context.
 833          --  Similarly, pragmas are analyzed in Install_Context, after all
 834          --  the implicit with's on parent units are generated.
 835
 836          else
 837             null;
 838          end if;
 839
 840          Next (Item);
 841       end loop;
 842
 843       --  Second pass: examine all limited_with clauses
 844
 845       Item := First (Context_Items (N));
 846       while Present (Item) loop
 847          if Nkind (Item) = N_With_Clause
 848            and then Limited_Present (Item)
 849          then
 850             --  No need to check errors on implicitly generated limited-with
 851             --  clauses.
 852
 853             if not Implicit_With (Item) then
 854
 855                --  Check compilation unit containing the limited-with clause
 856
 857                if Ukind /= N_Package_Declaration
 858                  and then Ukind /= N_Subprogram_Declaration
 859                  and then Ukind /= N_Package_Renaming_Declaration
 860                  and then Ukind /= N_Subprogram_Renaming_Declaration
 861                  and then Ukind not in N_Generic_Declaration
 862                  and then Ukind not in N_Generic_Renaming_Declaration
 863                  and then Ukind not in N_Generic_Instantiation
 864                then
 865                   Error_Msg_N ("limited with_clause not allowed here", Item);
 866
 867                --  Check wrong use of a limited with clause applied to the
 868                --  compilation unit containing the limited-with clause.
 869
 870                --      limited with P.Q;
 871                --      package P.Q is ...
 872
 873                elsif Unit (Library_Unit (Item)) = Unit (N) then
 874                   Error_Msg_N ("wrong use of limited-with clause", Item);
 875
 876                --  Check wrong use of limited-with clause applied to some
 877                --  immediate ancestor.
 878
 879                elsif Is_Child_Spec (Unit (N)) then
 880                   declare
 881                      Lib_U : constant Entity_Id := Unit (Library_Unit (Item));
 882                      P     : Node_Id;
 883
 884                   begin
 885                      P := Parent_Spec (Unit (N));
 886                      loop
 887                         if Unit (P) = Lib_U then
 888                            Error_Msg_N ("limited with_clause of immediate "
 889                                         & "ancestor not allowed", Item);
 890                            exit;
 891                         end if;
 892
 893                         exit when not Is_Child_Spec (Unit (P));
 894                         P := Parent_Spec (Unit (P));
 895                      end loop;
 896                   end;
 897                end if;
 898
 899                --  Check if the limited-withed unit is already visible through
 900                --  some context clause of the current compilation unit or some
 901                --  ancestor of the current compilation unit.
 902
 903                declare
 904                   Lim_Unit_Name : constant Node_Id := Name (Item);
 905                   Comp_Unit     : Node_Id;
 906                   It            : Node_Id;
 907                   Unit_Name     : Node_Id;
 908
 909                begin
 910                   Comp_Unit := N;
 911                   loop
 912                      It := First (Context_Items (Comp_Unit));
 913                      while Present (It) loop
 914                         if Item /= It
 915                           and then Nkind (It) = N_With_Clause
 916                           and then not Limited_Present (It)
 917                           and then
 918                              (Nkind (Unit (Library_Unit (It)))
 919                                = N_Package_Declaration
 920                             or else
 921                               Nkind (Unit (Library_Unit (It)))
 922                                = N_Package_Renaming_Declaration)
 923                         then
 924                            if Nkind (Unit (Library_Unit (It)))
 925                                 = N_Package_Declaration
 926                            then
 927                               Unit_Name := Name (It);
 928                            else
 929                               Unit_Name := Name (Unit (Library_Unit (It)));
 930                            end if;
 931
 932                            --  Check if the named package (or some ancestor)
 933                            --  leaves visible the full-view of the unit given
 934                            --  in the limited-with clause
 935
 936                            loop
 937                               if Designate_Same_Unit (Lim_Unit_Name,
 938                                                       Unit_Name)
 939                               then
 940                                  Error_Msg_Sloc := Sloc (It);
 941                                  Error_Msg_NE
 942                                    ("unlimited view visible through the"
 943                                     & " context clause found #",
 944                                     Item, It);
 945                                  Error_Msg_N
 946                                    ("simultaneous visibility of the limited"
 947                                     & " and unlimited views not allowed"
 948                                     , Item);
 949                                  exit;
 950
 951                               elsif Nkind (Unit_Name) = N_Identifier then
 952                                  exit;
 953                               end if;
 954
 955                               Unit_Name := Prefix (Unit_Name);
 956                            end loop;
 957                         end if;
 958
 959                         Next (It);
 960                      end loop;
 961
 962                      exit when not Is_Child_Spec (Unit (Comp_Unit));
 963
 964                      Comp_Unit := Parent_Spec (Unit (Comp_Unit));
 965                   end loop;
 966                end;
 967             end if;
 968
 969             --  Skip analyzing with clause if no unit, see above
 970
 971             if Present (Library_Unit (Item)) then
 972                Analyze (Item);
 973             end if;
 974
 975             --  A limited_with does not impose an elaboration order, but
 976             --  there is a semantic dependency for recompilation purposes.
 977
 978             if not Implicit_With (Item) then
 979                Version_Update (N, Library_Unit (Item));
 980             end if;
 981          end if;
 982
 983          Next (Item);
 984       end loop;
 985    end Analyze_Context;
 986
 987    -------------------------------
 988    -- Analyze_Package_Body_Stub --
 989    -------------------------------
 990
 991    procedure Analyze_Package_Body_Stub (N : Node_Id) is
 992       Id   : constant Entity_Id := Defining_Identifier (N);
 993       Nam  : Entity_Id;
 994
 995    begin
 996       --  The package declaration must be in the current declarative part
 997
 998       Check_Stub_Level (N);
 999       Nam := Current_Entity_In_Scope (Id);
1000
1001       if No (Nam) or else not Is_Package_Or_Generic_Package (Nam) then
1002          Error_Msg_N ("missing specification for package stub", N);
1003
1004       elsif Has_Completion (Nam)
1005         and then Present (Corresponding_Body (Unit_Declaration_Node (Nam)))
1006       then
1007          Error_Msg_N ("duplicate or redundant stub for package", N);
1008
1009       else
1010          --  Indicate that the body of the package exists. If we are doing
1011          --  only semantic analysis, the stub stands for the body. If we are
1012          --  generating code, the existence of the body will be confirmed
1013          --  when we load the proper body.
1014
1015          Set_Has_Completion (Nam);
1016          Set_Scope (Defining_Entity (N), Current_Scope);
1017          Generate_Reference (Nam, Id, 'b');
1018          Analyze_Proper_Body (N, Nam);
1019       end if;
1020    end Analyze_Package_Body_Stub;
1021
1022    -------------------------
1023    -- Analyze_Proper_Body --
1024    -------------------------
1025
1026    procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
1027       Subunit_Name      : constant Unit_Name_Type := Get_Unit_Name (N);
1028       Unum              : Unit_Number_Type;
1029
1030       procedure Optional_Subunit;
1031       --  This procedure is called when the main unit is a stub, or when we
1032       --  are not generating code. In such a case, we analyze the subunit if
1033       --  present, which is user-friendly and in fact required for ASIS, but
1034       --  we don't complain if the subunit is missing.
1035
1036       ----------------------
1037       -- Optional_Subunit --
1038       ----------------------
1039
1040       procedure Optional_Subunit is
1041          Comp_Unit : Node_Id;
1042
1043       begin
1044          --  Try to load subunit, but ignore any errors that occur during
1045          --  the loading of the subunit, by using the special feature in
1046          --  Errout to ignore all errors. Note that Fatal_Error will still
1047          --  be set, so we will be able to check for this case below.
1048
1049          if not ASIS_Mode then
1050             Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
1051          end if;
1052
1053          Unum :=
1054            Load_Unit
1055              (Load_Name  => Subunit_Name,
1056               Required   => False,
1057               Subunit    => True,
1058               Error_Node => N);
1059
1060          if not ASIS_Mode then
1061             Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
1062          end if;
1063
1064          --  All done if we successfully loaded the subunit
1065
1066          if Unum /= No_Unit
1067            and then (not Fatal_Error (Unum) or else Try_Semantics)
1068          then
1069             Comp_Unit := Cunit (Unum);
1070
1071             --  If the file was empty or seriously mangled, the unit
1072             --  itself may be missing.
1073
1074             if No (Unit (Comp_Unit)) then
1075                Error_Msg_N
1076                  ("subunit does not contain expected proper body", N);
1077
1078             elsif Nkind (Unit (Comp_Unit)) /= N_Subunit then
1079                Error_Msg_N
1080                  ("expected SEPARATE subunit, found child unit",
1081                   Cunit_Entity (Unum));
1082             else
1083                Set_Corresponding_Stub (Unit (Comp_Unit), N);
1084                Analyze_Subunit (Comp_Unit);
1085                Set_Library_Unit (N, Comp_Unit);
1086             end if;
1087
1088          elsif Unum = No_Unit
1089            and then Present (Nam)
1090          then
1091             if Is_Protected_Type (Nam) then
1092                Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N));
1093             else
1094                Set_Corresponding_Body (
1095                  Unit_Declaration_Node (Nam), Defining_Identifier (N));
1096             end if;
1097          end if;
1098       end Optional_Subunit;
1099
1100    --  Start of processing for Analyze_Proper_Body
1101
1102    begin
1103       --  If the subunit is already loaded, it means that the main unit
1104       --  is a subunit, and that the current unit is one of its parents
1105       --  which was being analyzed to provide the needed context for the
1106       --  analysis of the subunit. In this case we analyze the subunit and
1107       --  continue with the parent, without looking a subsequent subunits.
1108
1109       if Is_Loaded (Subunit_Name) then
1110
1111          --  If the proper body is already linked to the stub node,
1112          --  the stub is in a generic unit and just needs analyzing.
1113
1114          if Present (Library_Unit (N)) then
1115             Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1116             Analyze_Subunit (Library_Unit (N));
1117
1118          --  Otherwise we must load the subunit and link to it
1119
1120          else
1121             --  Load the subunit, this must work, since we originally
1122             --  loaded the subunit earlier on. So this will not really
1123             --  load it, just give access to it.
1124
1125             Unum :=
1126               Load_Unit
1127                 (Load_Name  => Subunit_Name,
1128                  Required   => True,
1129                  Subunit    => False,
1130                  Error_Node => N);
1131
1132             --  And analyze the subunit in the parent context (note that we
1133             --  do not call Semantics, since that would remove the parent
1134             --  context). Because of this, we have to manually reset the
1135             --  compiler state to Analyzing since it got destroyed by Load.
1136
1137             if Unum /= No_Unit then
1138                Compiler_State := Analyzing;
1139
1140                --  Check that the proper body is a subunit and not a child
1141                --  unit. If the unit was previously loaded, the error will
1142                --  have been emitted when copying the generic node, so we
1143                --  just return to avoid cascaded errors.
1144
1145                if Nkind (Unit (Cunit (Unum))) /= N_Subunit then
1146                   return;
1147                end if;
1148
1149                Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
1150                Analyze_Subunit (Cunit (Unum));
1151                Set_Library_Unit (N, Cunit (Unum));
1152             end if;
1153          end if;
1154
1155       --  If the main unit is a subunit, then we are just performing semantic
1156       --  analysis on that subunit, and any other subunits of any parent unit
1157       --  should be ignored, except that if we are building trees for ASIS
1158       --  usage we want to annotate the stub properly.
1159
1160       elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
1161         and then Subunit_Name /= Unit_Name (Main_Unit)
1162       then
1163          if ASIS_Mode then
1164             Optional_Subunit;
1165          end if;
1166
1167          --  But before we return, set the flag for unloaded subunits. This
1168          --  will suppress junk warnings of variables in the same declarative
1169          --  part (or a higher level one) that are in danger of looking unused
1170          --  when in fact there might be a declaration in the subunit that we
1171          --  do not intend to load.
1172
1173          Unloaded_Subunits := True;
1174          return;
1175
1176       --  If the subunit is not already loaded, and we are generating code,
1177       --  then this is the case where compilation started from the parent,
1178       --  and we are generating code for an entire subunit tree. In that
1179       --  case we definitely need to load the subunit.
1180
1181       --  In order to continue the analysis with the rest of the parent,
1182       --  and other subunits, we load the unit without requiring its
1183       --  presence, and emit a warning if not found, rather than terminating
1184       --  the compilation abruptly, as for other missing file problems.
1185
1186       elsif Original_Operating_Mode = Generate_Code then
1187
1188          --  If the proper body is already linked to the stub node,
1189          --  the stub is in a generic unit and just needs analyzing.
1190
1191          --  We update the version. Although we are not technically
1192          --  semantically dependent on the subunit, given our approach
1193          --  of macro substitution of subunits, it makes sense to
1194          --  include it in the version identification.
1195
1196          if Present (Library_Unit (N)) then
1197             Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1198             Analyze_Subunit (Library_Unit (N));
1199             Version_Update (Cunit (Main_Unit), Library_Unit (N));
1200
1201          --  Otherwise we must load the subunit and link to it
1202
1203          else
1204             Unum :=
1205               Load_Unit
1206                 (Load_Name  => Subunit_Name,
1207                  Required   => False,
1208                  Subunit    => True,
1209                  Error_Node => N);
1210
1211             if Original_Operating_Mode = Generate_Code
1212               and then Unum = No_Unit
1213             then
1214                Error_Msg_Name_1 := Subunit_Name;
1215                Error_Msg_Name_2 :=
1216                  Get_File_Name (Subunit_Name, Subunit => True);
1217                Error_Msg_N
1218                  ("subunit% in file{ not found!?", N);
1219                Subunits_Missing := True;
1220             end if;
1221
1222             --  Load_Unit may reset Compiler_State, since it may have been
1223             --  necessary to parse an additional units, so we make sure
1224             --  that we reset it to the Analyzing state.
1225
1226             Compiler_State := Analyzing;
1227
1228             if Unum /= No_Unit
1229               and then (not Fatal_Error (Unum) or else Try_Semantics)
1230             then
1231                if Debug_Flag_L then
1232                   Write_Str ("*** Loaded subunit from stub. Analyze");
1233                   Write_Eol;
1234                end if;
1235
1236                declare
1237                   Comp_Unit : constant Node_Id := Cunit (Unum);
1238
1239                begin
1240                   --  Check for child unit instead of subunit
1241
1242                   if Nkind (Unit (Comp_Unit)) /= N_Subunit then
1243                      Error_Msg_N
1244                        ("expected SEPARATE subunit, found child unit",
1245                         Cunit_Entity (Unum));
1246
1247                   --  OK, we have a subunit, so go ahead and analyze it,
1248                   --  and set Scope of entity in stub, for ASIS use.
1249
1250                   else
1251                      Set_Corresponding_Stub (Unit (Comp_Unit), N);
1252                      Analyze_Subunit (Comp_Unit);
1253                      Set_Library_Unit (N, Comp_Unit);
1254
1255                      --  We update the version. Although we are not technically
1256                      --  semantically dependent on the subunit, given our
1257                      --  approach of macro substitution of subunits, it makes
1258                      --  sense to include it in the version identification.
1259
1260                      Version_Update (Cunit (Main_Unit), Comp_Unit);
1261                   end if;
1262                end;
1263             end if;
1264          end if;
1265
1266          --  The remaining case is when the subunit is not already loaded and
1267          --  we are not generating code. In this case we are just performing
1268          --  semantic analysis on the parent, and we are not interested in
1269          --  the subunit. For subprograms, analyze the stub as a body. For
1270          --  other entities the stub has already been marked as completed.
1271
1272       else
1273          Optional_Subunit;
1274       end if;
1275
1276    end Analyze_Proper_Body;
1277
1278    ----------------------------------
1279    -- Analyze_Protected_Body_Stub --
1280    ----------------------------------
1281
1282    procedure Analyze_Protected_Body_Stub (N : Node_Id) is
1283       Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
1284
1285    begin
1286       Check_Stub_Level (N);
1287
1288       --  First occurence of name may have been as an incomplete type
1289
1290       if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
1291          Nam := Full_View (Nam);
1292       end if;
1293
1294       if No (Nam)
1295         or else not Is_Protected_Type (Etype (Nam))
1296       then
1297          Error_Msg_N ("missing specification for Protected body", N);
1298       else
1299          Set_Scope (Defining_Entity (N), Current_Scope);
1300          Set_Has_Completion (Etype (Nam));
1301          Generate_Reference (Nam, Defining_Identifier (N), 'b');
1302          Analyze_Proper_Body (N, Etype (Nam));
1303       end if;
1304    end Analyze_Protected_Body_Stub;
1305
1306    ----------------------------------
1307    -- Analyze_Subprogram_Body_Stub --
1308    ----------------------------------
1309
1310    --  A subprogram body stub can appear with or without a previous
1311    --  specification. If there is one, the analysis of the body will
1312    --  find it and verify conformance.  The formals appearing in the
1313    --  specification of the stub play no role, except for requiring an
1314    --  additional conformance check. If there is no previous subprogram
1315    --  declaration, the stub acts as a spec, and provides the defining
1316    --  entity for the subprogram.
1317
1318    procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
1319       Decl : Node_Id;
1320
1321    begin
1322       Check_Stub_Level (N);
1323
1324       --  Verify that the identifier for the stub is unique within this
1325       --  declarative part.
1326
1327       if Nkind (Parent (N)) = N_Block_Statement
1328         or else Nkind (Parent (N)) = N_Package_Body
1329         or else Nkind (Parent (N)) = N_Subprogram_Body
1330       then
1331          Decl := First (Declarations (Parent (N)));
1332          while Present (Decl)
1333            and then Decl /= N
1334          loop
1335             if Nkind (Decl) = N_Subprogram_Body_Stub
1336               and then (Chars (Defining_Unit_Name (Specification (Decl)))
1337                       = Chars (Defining_Unit_Name (Specification (N))))
1338             then
1339                Error_Msg_N ("identifier for stub is not unique", N);
1340             end if;
1341
1342             Next (Decl);
1343          end loop;
1344       end if;
1345
1346       --  Treat stub as a body, which checks conformance if there is a previous
1347       --  declaration, or else introduces entity and its signature.
1348
1349       Analyze_Subprogram_Body (N);
1350       Analyze_Proper_Body (N, Empty);
1351    end Analyze_Subprogram_Body_Stub;
1352
1353    ---------------------
1354    -- Analyze_Subunit --
1355    ---------------------
1356
1357    --  A subunit is compiled either by itself (for semantic checking)
1358    --  or as part of compiling the parent (for code generation). In
1359    --  either case, by the time we actually process the subunit, the
1360    --  parent has already been installed and analyzed. The node N is
1361    --  a compilation unit, whose context needs to be treated here,
1362    --  because we come directly here from the parent without calling
1363    --  Analyze_Compilation_Unit.
1364
1365    --  The compilation context includes the explicit context of the
1366    --  subunit, and the context of the parent, together with the parent
1367    --  itself. In order to compile the current context, we remove the
1368    --  one inherited from the parent, in order to have a clean visibility
1369    --  table. We restore the parent context before analyzing the proper
1370    --  body itself. On exit, we remove only the explicit context of the
1371    --  subunit.
1372
1373    procedure Analyze_Subunit (N : Node_Id) is
1374       Lib_Unit : constant Node_Id   := Library_Unit (N);
1375       Par_Unit : constant Entity_Id := Current_Scope;
1376
1377       Lib_Spec        : Node_Id := Library_Unit (Lib_Unit);
1378       Num_Scopes      : Int := 0;
1379       Use_Clauses     : array (1 .. Scope_Stack.Last) of Node_Id;
1380       Enclosing_Child : Entity_Id := Empty;
1381       Svg             : constant Suppress_Array := Scope_Suppress;
1382
1383       procedure Analyze_Subunit_Context;
1384       --  Capture names in use clauses of the subunit. This must be done
1385       --  before re-installing parent declarations, because items in the
1386       --  context must not be hidden by declarations local to the parent.
1387
1388       procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
1389       --  Recursive procedure to restore scope of all ancestors of subunit,
1390       --  from outermost in. If parent is not a subunit, the call to install
1391       --  context installs context of spec and (if parent is a child unit)
1392       --  the context of its parents as well. It is confusing that parents
1393       --  should be treated differently in both cases, but the semantics are
1394       --  just not identical.
1395
1396       procedure Re_Install_Use_Clauses;
1397       --  As part of the removal of the parent scope, the use clauses are
1398       --  removed, to be reinstalled when the context of the subunit has
1399       --  been analyzed. Use clauses may also have been affected by the
1400       --  analysis of the context of the subunit, so they have to be applied
1401       --  again, to insure that the compilation environment of the rest of
1402       --  the parent unit is identical.
1403
1404       procedure Remove_Scope;
1405       --  Remove current scope from scope stack, and preserve the list
1406       --  of use clauses in it, to be reinstalled after context is analyzed.
1407
1408       -----------------------------
1409       -- Analyze_Subunit_Context --
1410       -----------------------------
1411
1412       procedure Analyze_Subunit_Context is
1413          Item      :  Node_Id;
1414          Nam       :  Node_Id;
1415          Unit_Name : Entity_Id;
1416
1417       begin
1418          Analyze_Context (N);
1419
1420          --  Make withed units immediately visible. If child unit, make the
1421          --  ultimate parent immediately visible.
1422
1423          Item := First (Context_Items (N));
1424          while Present (Item) loop
1425             if Nkind (Item) = N_With_Clause then
1426
1427                --  Protect frontend against previous errors in context clauses
1428
1429                if Nkind (Name (Item)) /= N_Selected_Component then
1430                   Unit_Name := Entity (Name (Item));
1431                   while Is_Child_Unit (Unit_Name) loop
1432                      Set_Is_Visible_Child_Unit (Unit_Name);
1433                      Unit_Name := Scope (Unit_Name);
1434                   end loop;
1435
1436                   if not Is_Immediately_Visible (Unit_Name) then
1437                      Set_Is_Immediately_Visible (Unit_Name);
1438                      Set_Context_Installed (Item);
1439                   end if;
1440                end if;
1441
1442             elsif Nkind (Item) = N_Use_Package_Clause then
1443                Nam := First (Names (Item));
1444                while Present (Nam) loop
1445                   Analyze (Nam);
1446                   Next (Nam);
1447                end loop;
1448
1449             elsif Nkind (Item) = N_Use_Type_Clause then
1450                Nam := First (Subtype_Marks (Item));
1451                while Present (Nam) loop
1452                   Analyze (Nam);
1453                   Next (Nam);
1454                end loop;
1455             end if;
1456
1457             Next (Item);
1458          end loop;
1459
1460          --  Reset visibility of withed units. They will be made visible
1461          --  again when we install the subunit context.
1462
1463          Item := First (Context_Items (N));
1464          while Present (Item) loop
1465             if Nkind (Item) = N_With_Clause
1466
1467                --  Protect frontend against previous errors in context clauses
1468
1469               and then Nkind (Name (Item)) /= N_Selected_Component
1470             then
1471                Unit_Name := Entity (Name (Item));
1472                while Is_Child_Unit (Unit_Name) loop
1473                   Set_Is_Visible_Child_Unit (Unit_Name, False);
1474                   Unit_Name := Scope (Unit_Name);
1475                end loop;
1476
1477                if Context_Installed (Item) then
1478                   Set_Is_Immediately_Visible (Unit_Name, False);
1479                   Set_Context_Installed (Item, False);
1480                end if;
1481             end if;
1482
1483             Next (Item);
1484          end loop;
1485       end Analyze_Subunit_Context;
1486
1487       ------------------------
1488       -- Re_Install_Parents --
1489       ------------------------
1490
1491       procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is
1492          E : Entity_Id;
1493
1494       begin
1495          if Nkind (Unit (L)) = N_Subunit then
1496             Re_Install_Parents (Library_Unit (L), Scope (Scop));
1497          end if;
1498
1499          Install_Context (L);
1500
1501          --  If the subunit occurs within a child unit, we must restore the
1502          --  immediate visibility of any siblings that may occur in context.
1503
1504          if Present (Enclosing_Child) then
1505             Install_Siblings (Enclosing_Child, L);
1506          end if;
1507
1508          New_Scope (Scop);
1509
1510          if Scop /= Par_Unit then
1511             Set_Is_Immediately_Visible (Scop);
1512          end if;
1513
1514          --  Make entities in scope visible again. For child units, restore
1515          --  visibility only if they are actually in context.
1516
1517          E := First_Entity (Current_Scope);
1518          while Present (E) loop
1519             if not Is_Child_Unit (E)
1520               or else Is_Visible_Child_Unit (E)
1521             then
1522                Set_Is_Immediately_Visible (E);
1523             end if;
1524
1525             Next_Entity (E);
1526          end loop;
1527
1528          --  A subunit appears within a body, and for a nested subunits
1529          --  all the parents are bodies. Restore full visibility of their
1530          --  private entities.
1531
1532          if Ekind (Scop) = E_Package then
1533             Set_In_Package_Body (Scop);
1534             Install_Private_Declarations (Scop);
1535          end if;
1536       end Re_Install_Parents;
1537
1538       ----------------------------
1539       -- Re_Install_Use_Clauses --
1540       ----------------------------
1541
1542       procedure Re_Install_Use_Clauses is
1543          U  : Node_Id;
1544       begin
1545          for J in reverse 1 .. Num_Scopes loop
1546             U := Use_Clauses (J);
1547             Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
1548             Install_Use_Clauses (U, Force_Installation => True);
1549          end loop;
1550       end Re_Install_Use_Clauses;
1551
1552       ------------------
1553       -- Remove_Scope --
1554       ------------------
1555
1556       procedure Remove_Scope is
1557          E : Entity_Id;
1558
1559       begin
1560          Num_Scopes := Num_Scopes + 1;
1561          Use_Clauses (Num_Scopes) :=
1562            Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
1563
1564          E := First_Entity (Current_Scope);
1565          while Present (E) loop
1566             Set_Is_Immediately_Visible (E, False);
1567             Next_Entity (E);
1568          end loop;
1569
1570          if Is_Child_Unit (Current_Scope) then
1571             Enclosing_Child := Current_Scope;
1572          end if;
1573
1574          Pop_Scope;
1575       end Remove_Scope;
1576
1577    --  Start of processing for Analyze_Subunit
1578
1579    begin
1580       if not Is_Empty_List (Context_Items (N)) then
1581
1582          --  Save current use clauses
1583
1584          Remove_Scope;
1585          Remove_Context (Lib_Unit);
1586
1587          --  Now remove parents and their context, including enclosing
1588          --  subunits and the outer parent body which is not a subunit.
1589
1590          if Present (Lib_Spec) then
1591             Remove_Context (Lib_Spec);
1592
1593             while Nkind (Unit (Lib_Spec)) = N_Subunit loop
1594                Lib_Spec := Library_Unit (Lib_Spec);
1595                Remove_Scope;
1596                Remove_Context (Lib_Spec);
1597             end loop;
1598
1599             if Nkind (Unit (Lib_Unit)) = N_Subunit then
1600                Remove_Scope;
1601             end if;
1602
1603             if Nkind (Unit (Lib_Spec)) = N_Package_Body then
1604                Remove_Context (Library_Unit (Lib_Spec));
1605             end if;
1606          end if;
1607
1608          Set_Is_Immediately_Visible (Par_Unit, False);
1609
1610          Analyze_Subunit_Context;
1611
1612          Re_Install_Parents (Lib_Unit, Par_Unit);
1613          Set_Is_Immediately_Visible (Par_Unit);
1614
1615          --  If the context includes a child unit of the parent of the
1616          --  subunit, the parent will have been removed from visibility,
1617          --  after compiling that cousin in the context. The visibility
1618          --  of the parent must be restored now. This also applies if the
1619          --  context includes another subunit of the same parent which in
1620          --  turn includes a child unit in its context.
1621
1622          if Ekind (Par_Unit) = E_Package then
1623             if not Is_Immediately_Visible (Par_Unit)
1624               or else (Present (First_Entity (Par_Unit))
1625                         and then not Is_Immediately_Visible
1626                                       (First_Entity (Par_Unit)))
1627             then
1628                Set_Is_Immediately_Visible   (Par_Unit);
1629                Install_Visible_Declarations (Par_Unit);
1630                Install_Private_Declarations (Par_Unit);
1631             end if;
1632          end if;
1633
1634          Re_Install_Use_Clauses;
1635          Install_Context (N);
1636
1637          --  Restore state of suppress flags for current body
1638
1639          Scope_Suppress := Svg;
1640
1641          --  If the subunit is within a child unit, then siblings of any
1642          --  parent unit that appear in the context clause of the subunit
1643          --  must also be made immediately visible.
1644
1645          if Present (Enclosing_Child) then
1646             Install_Siblings (Enclosing_Child, N);
1647          end if;
1648
1649       end if;
1650
1651       Analyze (Proper_Body (Unit (N)));
1652       Remove_Context (N);
1653    end Analyze_Subunit;
1654
1655    ----------------------------
1656    -- Analyze_Task_Body_Stub --
1657    ----------------------------
1658
1659    procedure Analyze_Task_Body_Stub (N : Node_Id) is
1660       Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
1661       Loc : constant Source_Ptr := Sloc (N);
1662
1663    begin
1664       Check_Stub_Level (N);
1665
1666       --  First occurence of name may have been as an incomplete type
1667
1668       if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
1669          Nam := Full_View (Nam);
1670       end if;
1671
1672       if No (Nam)
1673         or else not Is_Task_Type (Etype (Nam))
1674       then
1675          Error_Msg_N ("missing specification for task body", N);
1676       else
1677          Set_Scope (Defining_Entity (N), Current_Scope);
1678          Generate_Reference (Nam, Defining_Identifier (N), 'b');
1679          Set_Has_Completion (Etype (Nam));
1680          Analyze_Proper_Body (N, Etype (Nam));
1681
1682          --  Set elaboration flag to indicate that entity is callable.
1683          --  This cannot be done in the expansion of the body  itself,
1684          --  because the proper body is not in a declarative part. This
1685          --  is only done if expansion is active, because the context
1686          --  may be generic and the flag not defined yet.
1687
1688          if Expander_Active then
1689             Insert_After (N,
1690               Make_Assignment_Statement (Loc,
1691                 Name =>
1692                   Make_Identifier (Loc,
1693                     New_External_Name (Chars (Etype (Nam)), 'E')),
1694                  Expression => New_Reference_To (Standard_True, Loc)));
1695          end if;
1696
1697       end if;
1698    end Analyze_Task_Body_Stub;
1699
1700    -------------------------
1701    -- Analyze_With_Clause --
1702    -------------------------
1703
1704    --  Analyze the declaration of a unit in a with clause. At end,
1705    --  label the with clause with the defining entity for the unit.
1706
1707    procedure Analyze_With_Clause (N : Node_Id) is
1708
1709       --  Retrieve the original kind of the unit node, before analysis.
1710       --  If it is a subprogram instantiation, its analysis below will
1711       --  rewrite as the declaration of the wrapper package. If the same
1712       --  instantiation appears indirectly elsewhere in the context, it
1713       --  will have been analyzed already.
1714
1715       Unit_Kind : constant Node_Kind :=
1716                     Nkind (Original_Node (Unit (Library_Unit (N))));
1717
1718       E_Name    : Entity_Id;
1719       Par_Name  : Entity_Id;
1720       Pref      : Node_Id;
1721       U         : Node_Id;
1722
1723       Intunit : Boolean;
1724       --  Set True if the unit currently being compiled is an internal unit
1725
1726       Save_Style_Check : constant Boolean := Opt.Style_Check;
1727       Save_C_Restrict  : constant Save_Cunit_Boolean_Restrictions :=
1728                            Cunit_Boolean_Restrictions_Save;
1729
1730    begin
1731       if Limited_Present (N) then
1732
1733          --  Ada 2005 (AI-50217): Build visibility structures but do not
1734          --  analyze unit
1735
1736          Build_Limited_Views (N);
1737          return;
1738       end if;
1739
1740       --  We reset ordinary style checking during the analysis of a with'ed
1741       --  unit, but we do NOT reset GNAT special analysis mode (the latter
1742       --  definitely *does* apply to with'ed units).
1743
1744       if not GNAT_Mode then
1745          Style_Check := False;
1746       end if;
1747
1748       --  If the library unit is a predefined unit, and we are in high
1749       --  integrity mode, then temporarily reset Configurable_Run_Time_Mode
1750       --  for the analysis of the with'ed unit. This mode does not prevent
1751       --  explicit with'ing of run-time units.
1752
1753       if Configurable_Run_Time_Mode
1754         and then
1755           Is_Predefined_File_Name
1756             (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
1757       then
1758          Configurable_Run_Time_Mode := False;
1759          Semantics (Library_Unit (N));
1760          Configurable_Run_Time_Mode := True;
1761
1762       else
1763          Semantics (Library_Unit (N));
1764       end if;
1765
1766       U := Unit (Library_Unit (N));
1767       Check_Restriction_No_Dependence (Name (N), N);
1768       Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
1769
1770       --  Following checks are skipped for dummy packages (those supplied
1771       --  for with's where no matching file could be found). Such packages
1772       --  are identified by the Sloc value being set to No_Location
1773
1774       if Sloc (U) /= No_Location then
1775
1776          --  Check restrictions, except that we skip the check if this
1777          --  is an internal unit unless we are compiling the internal
1778          --  unit as the main unit. We also skip this for dummy packages.
1779
1780          if not Intunit or else Current_Sem_Unit = Main_Unit then
1781             Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N);
1782          end if;
1783
1784          --  Check for inappropriate with of internal implementation unit
1785          --  if we are currently compiling the main unit and the main unit
1786          --  is itself not an internal unit. We do not issue this message
1787          --  for implicit with's generated by the compiler itself.
1788
1789          if Implementation_Unit_Warnings
1790            and then Current_Sem_Unit = Main_Unit
1791            and then not Intunit
1792            and then not Implicit_With (N)
1793            and then not GNAT_Mode
1794          then
1795             declare
1796                U_Kind : constant Kind_Of_Unit :=
1797                           Get_Kind_Of_Unit (Get_Source_Unit (U));
1798
1799             begin
1800                if U_Kind = Implementation_Unit then
1801                   Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
1802                   Error_Msg_N
1803                     ("\use of this unit is non-portable " &
1804                      "and version-dependent?",
1805                      Name (N));
1806
1807                elsif U_Kind = Ada_05_Unit
1808                  and then Ada_Version < Ada_05
1809                  and then Warn_On_Ada_2005_Compatibility
1810                then
1811                   Error_Msg_N ("& is an Ada 2005 unit?", Name (N));
1812                end if;
1813             end;
1814          end if;
1815       end if;
1816
1817       --  Semantic analysis of a generic unit is performed on a copy of
1818       --  the original tree. Retrieve the entity on  which semantic info
1819       --  actually appears.
1820
1821       if Unit_Kind in N_Generic_Declaration then
1822          E_Name := Defining_Entity (U);
1823
1824       --  Note: in the following test, Unit_Kind is the original Nkind, but
1825       --  in the case of an instantiation, semantic analysis above will
1826       --  have replaced the unit by its instantiated version. If the instance
1827       --  body has been generated, the instance now denotes the body entity.
1828       --  For visibility purposes we need the entity of its spec.
1829
1830       elsif (Unit_Kind = N_Package_Instantiation
1831               or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
1832                 N_Package_Instantiation)
1833         and then Nkind (U) = N_Package_Body
1834       then
1835          E_Name := Corresponding_Spec (U);
1836
1837       elsif Unit_Kind = N_Package_Instantiation
1838         and then Nkind (U) = N_Package_Instantiation
1839       then
1840          --  If the instance has not been rewritten as a package declaration,
1841          --  then it appeared already in a previous with clause. Retrieve
1842          --  the entity from the previous instance.
1843
1844          E_Name := Defining_Entity (Specification (Instance_Spec (U)));
1845
1846       elsif Unit_Kind in N_Subprogram_Instantiation then
1847
1848          --  Instantiation node is replaced with a package that contains
1849          --  renaming declarations and instance itself. The subprogram
1850          --  Instance is declared in the visible part of the wrapper package.
1851
1852          E_Name := First_Entity (Defining_Entity (U));
1853          while Present (E_Name) loop
1854             exit when Is_Subprogram (E_Name)
1855               and then Is_Generic_Instance (E_Name);
1856             E_Name := Next_Entity (E_Name);
1857          end loop;
1858
1859       elsif Unit_Kind = N_Package_Renaming_Declaration
1860         or else Unit_Kind in N_Generic_Renaming_Declaration
1861       then
1862          E_Name := Defining_Entity (U);
1863
1864       elsif Unit_Kind = N_Subprogram_Body
1865         and then Nkind (Name (N)) = N_Selected_Component
1866         and then not Acts_As_Spec (Library_Unit (N))
1867       then
1868          --  For a child unit that has no spec, one has been created and
1869          --  analyzed. The entity required is that of the spec.
1870
1871          E_Name := Corresponding_Spec (U);
1872
1873       else
1874          E_Name := Defining_Entity (U);
1875       end if;
1876
1877       if Nkind (Name (N)) = N_Selected_Component then
1878
1879          --  Child unit in a with clause
1880
1881          Change_Selected_Component_To_Expanded_Name (Name (N));
1882       end if;
1883
1884       --  Restore style checks and restrictions
1885
1886       Style_Check := Save_Style_Check;
1887       Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
1888
1889       --  Record the reference, but do NOT set the unit as referenced, we want
1890       --  to consider the unit as unreferenced if this is the only reference
1891       --  that occurs.
1892
1893       Set_Entity_With_Style_Check (Name (N), E_Name);
1894       Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
1895
1896       if Is_Child_Unit (E_Name) then
1897          Pref     := Prefix (Name (N));
1898          Par_Name := Scope (E_Name);
1899          while Nkind (Pref) = N_Selected_Component loop
1900             Change_Selected_Component_To_Expanded_Name (Pref);
1901             Set_Entity_With_Style_Check (Pref, Par_Name);
1902
1903             Generate_Reference (Par_Name, Pref);
1904             Pref := Prefix (Pref);
1905
1906             --  If E_Name is the dummy entity for a nonexistent unit, its scope
1907             --  is set to Standard_Standard, and no attempt should be made to
1908             --  further unwind scopes.
1909
1910             if Par_Name /= Standard_Standard then
1911                Par_Name := Scope (Par_Name);
1912             end if;
1913          end loop;
1914
1915          if Present (Entity (Pref))
1916            and then not Analyzed (Parent (Parent (Entity (Pref))))
1917          then
1918             --  If the entity is set without its unit being compiled, the
1919             --  original parent is a renaming, and Par_Name is the renamed
1920             --  entity. For visibility purposes, we need the original entity,
1921             --  which must be analyzed now because Load_Unit directly retrieves
1922             --  the renamed unit, and the renaming declaration itself has not
1923             --  been analyzed.
1924
1925             Analyze (Parent (Parent (Entity (Pref))));
1926             pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
1927             Par_Name := Entity (Pref);
1928          end if;
1929
1930          Set_Entity_With_Style_Check (Pref, Par_Name);
1931          Generate_Reference (Par_Name, Pref);
1932       end if;
1933
1934       --  If the withed unit is System, and a system extension pragma is
1935       --  present, compile the extension now, rather than waiting for a
1936       --  visibility check on a specific entity.
1937
1938       if Chars (E_Name) = Name_System
1939         and then Scope (E_Name) = Standard_Standard
1940         and then Present (System_Extend_Unit)
1941         and then Present_System_Aux (N)
1942       then
1943          --  If the extension is not present, an error will have been emitted
1944
1945          null;
1946       end if;
1947
1948       --  Ada 2005 (AI-262): Remove from visibility the entity corresponding
1949       --  to private_with units; they will be made visible later (just before
1950       --  the private part is analyzed)
1951
1952       if Private_Present (N) then
1953          Set_Is_Immediately_Visible (E_Name, False);
1954       end if;
1955
1956       --  Check for with'ing obsolescent package. Exclude subprograms here
1957       --  since we will catch those on the call rather than the WITH.
1958
1959       if Is_Package_Or_Generic_Package (E_Name) then
1960          Check_Obsolescent (E_Name, N);
1961       end if;
1962    end Analyze_With_Clause;
1963
1964    ------------------------------
1965    -- Analyze_With_Type_Clause --
1966    ------------------------------
1967
1968    procedure Analyze_With_Type_Clause (N : Node_Id) is
1969       Loc  : constant Source_Ptr := Sloc (N);
1970       Nam  : constant Node_Id    := Name (N);
1971       Pack : Node_Id;
1972       Decl : Node_Id;
1973       P    : Entity_Id;
1974       Unum : Unit_Number_Type;
1975       Sel  : Node_Id;
1976
1977       procedure Decorate_Tagged_Type (T : Entity_Id);
1978       --  Set basic attributes of type, including its class_wide type
1979
1980       function In_Chain (E : Entity_Id) return Boolean;
1981       --  Check that the imported type is not already in the homonym chain,
1982       --  for example through a with_type clause in a parent unit.
1983
1984       --------------------------
1985       -- Decorate_Tagged_Type --
1986       --------------------------
1987
1988       procedure Decorate_Tagged_Type (T : Entity_Id) is
1989          CW : Entity_Id;
1990
1991       begin
1992          Set_Ekind (T, E_Record_Type);
1993          Set_Is_Tagged_Type (T);
1994          Set_Etype (T, T);
1995          Set_From_With_Type (T);
1996          Set_Scope (T, P);
1997
1998          if not In_Chain (T) then
1999             Set_Homonym (T, Current_Entity (T));
2000             Set_Current_Entity (T);
2001          end if;
2002
2003          --  Build bogus class_wide type, if not previously done
2004
2005          if No (Class_Wide_Type (T)) then
2006             CW := Make_Defining_Identifier (Loc,  New_Internal_Name ('S'));
2007
2008             Set_Ekind            (CW, E_Class_Wide_Type);
2009             Set_Etype            (CW, T);
2010             Set_Scope            (CW, P);
2011             Set_Is_Tagged_Type   (CW);
2012             Set_Is_First_Subtype (CW, True);
2013             Init_Size_Align      (CW);
2014             Set_Has_Unknown_Discriminants
2015                                  (CW, True);
2016             Set_Class_Wide_Type  (CW, CW);
2017             Set_Equivalent_Type  (CW, Empty);
2018             Set_From_With_Type   (CW);
2019
2020             Set_Class_Wide_Type (T, CW);
2021          end if;
2022       end Decorate_Tagged_Type;
2023
2024       --------------
2025       -- In_Chain --
2026       --------------
2027
2028       function In_Chain (E : Entity_Id) return Boolean is
2029          H : Entity_Id;
2030
2031       begin
2032          H := Current_Entity (E);
2033          while Present (H) loop
2034             if H = E then
2035                return True;
2036             else
2037                H := Homonym (H);
2038             end if;
2039          end loop;
2040
2041          return False;
2042       end In_Chain;
2043
2044    --  Start of processing for Analyze_With_Type_Clause
2045
2046    begin
2047       if Nkind (Nam) = N_Selected_Component then
2048          Pack := New_Copy_Tree (Prefix (Nam));
2049          Sel  := Selector_Name (Nam);
2050
2051       else
2052          Error_Msg_N ("illegal name for imported type", Nam);
2053          return;
2054       end if;
2055
2056       Decl :=
2057         Make_Package_Declaration (Loc,
2058           Specification =>
2059              (Make_Package_Specification (Loc,
2060                Defining_Unit_Name   => Pack,
2061                Visible_Declarations => New_List,
2062                End_Label            => Empty)));
2063
2064       Unum :=
2065         Load_Unit
2066           (Load_Name  => Get_Unit_Name (Decl),
2067            Required   => True,
2068            Subunit    => False,
2069            Error_Node => Nam);
2070
2071       if Unum = No_Unit
2072          or else Nkind (Unit (Cunit (Unum))) /= N_Package_Declaration
2073       then
2074          Error_Msg_N ("imported type must be declared in package", Nam);
2075          return;
2076
2077       elsif Unum = Current_Sem_Unit then
2078
2079          --  If type is defined in unit being analyzed, then the clause
2080          --  is redundant.
2081
2082          return;
2083
2084       else
2085          P := Cunit_Entity (Unum);
2086       end if;
2087
2088       --  Find declaration for imported type, and set its basic attributes
2089       --  if it has not been analyzed (which will be the case if there is
2090       --  circular dependence).
2091
2092       declare
2093          Decl : Node_Id;
2094          Typ  : Entity_Id;
2095
2096       begin
2097          if not Analyzed (Cunit (Unum))
2098            and then not From_With_Type (P)
2099          then
2100             Set_Ekind (P, E_Package);
2101             Set_Etype (P, Standard_Void_Type);
2102             Set_From_With_Type (P);
2103             Set_Scope (P, Standard_Standard);
2104             Set_Homonym (P, Current_Entity (P));
2105             Set_Current_Entity (P);
2106
2107          elsif Analyzed (Cunit (Unum))
2108            and then Is_Child_Unit (P)
2109          then
2110             --  If the child unit is already in scope, indicate that it is
2111             --  visible, and remains so after intervening calls to rtsfind.
2112
2113             Set_Is_Visible_Child_Unit (P);
2114          end if;
2115
2116          if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then
2117
2118             --  Make parent packages visible
2119
2120             declare
2121                Parent_Comp : Node_Id;
2122                Parent_Id   : Entity_Id;
2123                Child       : Entity_Id;
2124
2125             begin
2126                Child   := P;
2127                Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
2128
2129                loop
2130                   Parent_Id := Defining_Entity (Unit (Parent_Comp));
2131                   Set_Scope (Child, Parent_Id);
2132
2133                   --  The type may be imported from a child unit, in which
2134                   --  case the current compilation appears in the name. Do
2135                   --  not change its visibility here because it will conflict
2136                   --  with the subsequent normal processing.
2137
2138                   if not Analyzed (Unit_Declaration_Node (Parent_Id))
2139                     and then Parent_Id /= Cunit_Entity (Current_Sem_Unit)
2140                   then
2141                      Set_Ekind (Parent_Id, E_Package);
2142                      Set_Etype (Parent_Id, Standard_Void_Type);
2143
2144                      --  The same package may appear is several with_type
2145                      --  clauses.
2146
2147                      if not From_With_Type (Parent_Id) then
2148                         Set_Homonym (Parent_Id, Current_Entity (Parent_Id));
2149                         Set_Current_Entity (Parent_Id);
2150                         Set_From_With_Type (Parent_Id);
2151                      end if;
2152                   end if;
2153
2154                   Set_Is_Immediately_Visible (Parent_Id);
2155
2156                   Child := Parent_Id;
2157                   Parent_Comp := Parent_Spec (Unit (Parent_Comp));
2158                   exit when No (Parent_Comp);
2159                end loop;
2160
2161                Set_Scope (Parent_Id, Standard_Standard);
2162             end;
2163          end if;
2164
2165          --  Even if analyzed, the package may not be currently visible. It
2166          --  must be while the with_type clause is active.
2167
2168          Set_Is_Immediately_Visible (P);
2169
2170          Decl :=
2171            First (Visible_Declarations (Specification (Unit (Cunit (Unum)))));
2172          while Present (Decl) loop
2173             if Nkind (Decl) = N_Full_Type_Declaration
2174               and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
2175             then
2176                Typ := Defining_Identifier (Decl);
2177
2178                if Tagged_Present (N) then
2179
2180                   --  The declaration must indicate that this is a tagged
2181                   --  type or a type extension.
2182
2183                   if (Nkind (Type_Definition (Decl)) = N_Record_Definition
2184                        and then Tagged_Present (Type_Definition (Decl)))
2185                     or else
2186                       (Nkind (Type_Definition (Decl))
2187                           = N_Derived_Type_Definition
2188                          and then Present
2189                            (Record_Extension_Part (Type_Definition (Decl))))
2190                   then
2191                      null;
2192                   else
2193                      Error_Msg_N ("imported type is not a tagged type", Nam);
2194                      return;
2195                   end if;
2196
2197                   if not Analyzed (Decl) then
2198
2199                      --  Unit is not currently visible. Add basic attributes
2200                      --  to type and build its class-wide type.
2201
2202                      Init_Size_Align (Typ);
2203                      Decorate_Tagged_Type (Typ);
2204                   end if;
2205
2206                else
2207                   if Nkind (Type_Definition (Decl))
2208                      /= N_Access_To_Object_Definition
2209                   then
2210                      Error_Msg_N
2211                       ("imported type is not an access type", Nam);
2212
2213                   elsif not Analyzed (Decl) then
2214                      Set_Ekind                    (Typ, E_Access_Type);
2215                      Set_Etype                    (Typ, Typ);
2216                      Set_Scope                    (Typ, P);
2217                      Init_Size                    (Typ, System_Address_Size);
2218                      Init_Alignment               (Typ);
2219                      Set_Directly_Designated_Type (Typ, Standard_Integer);
2220                      Set_From_With_Type           (Typ);
2221
2222                      if not In_Chain (Typ) then
2223                         Set_Homonym               (Typ, Current_Entity (Typ));
2224                         Set_Current_Entity        (Typ);
2225                      end if;
2226                   end if;
2227                end if;
2228
2229                Set_Entity (Sel, Typ);
2230                return;
2231
2232             elsif ((Nkind (Decl) = N_Private_Type_Declaration
2233                       and then Tagged_Present (Decl))
2234                 or else (Nkind (Decl) = N_Private_Extension_Declaration))
2235               and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
2236             then
2237                Typ := Defining_Identifier (Decl);
2238
2239                if not Tagged_Present (N) then
2240                   Error_Msg_N ("type must be declared tagged", N);
2241
2242                elsif not Analyzed (Decl) then
2243                   Decorate_Tagged_Type (Typ);
2244                end if;
2245
2246                Set_Entity (Sel, Typ);
2247                Set_From_With_Type (Typ);
2248                return;
2249             end if;
2250
2251             Decl := Next (Decl);
2252          end loop;
2253
2254          Error_Msg_NE ("not a visible access or tagged type in&", Nam, P);
2255       end;
2256    end Analyze_With_Type_Clause;
2257
2258    -----------------------------
2259    -- Check_With_Type_Clauses --
2260    -----------------------------
2261
2262    procedure Check_With_Type_Clauses (N : Node_Id) is
2263       Lib_Unit : constant Node_Id := Unit (N);
2264
2265       procedure Check_Parent_Context (U : Node_Id);
2266       --  Examine context items of parent unit to locate with_type clauses
2267
2268       --------------------------
2269       -- Check_Parent_Context --
2270       --------------------------
2271
2272       procedure Check_Parent_Context (U : Node_Id) is
2273          Item : Node_Id;
2274
2275       begin
2276          Item := First (Context_Items (U));
2277          while Present (Item) loop
2278             if Nkind (Item) = N_With_Type_Clause
2279               and then not Error_Posted (Item)
2280               and then
2281                 From_With_Type (Scope (Entity (Selector_Name (Name (Item)))))
2282             then
2283                Error_Msg_Sloc := Sloc (Item);
2284                Error_Msg_N ("missing With_Clause for With_Type_Clause#", N);
2285             end if;
2286
2287             Next (Item);
2288          end loop;
2289       end Check_Parent_Context;
2290
2291    --  Start of processing for Check_With_Type_Clauses
2292
2293    begin
2294       if Extensions_Allowed
2295         and then (Nkind (Lib_Unit) = N_Package_Body
2296                    or else Nkind (Lib_Unit) = N_Subprogram_Body)
2297       then
2298          Check_Parent_Context (Library_Unit (N));
2299
2300          if Is_Child_Spec (Unit (Library_Unit (N))) then
2301             Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N))));
2302          end if;
2303       end if;
2304    end Check_With_Type_Clauses;
2305
2306    ------------------------------
2307    -- Check_Private_Child_Unit --
2308    ------------------------------
2309
2310    procedure Check_Private_Child_Unit (N : Node_Id) is
2311       Lib_Unit   : constant Node_Id := Unit (N);
2312       Item       : Node_Id;
2313       Curr_Unit  : Entity_Id;
2314       Sub_Parent : Node_Id;
2315       Priv_Child : Entity_Id;
2316       Par_Lib    : Entity_Id;
2317       Par_Spec   : Node_Id;
2318
2319       function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean;
2320       --  Returns true if and only if the library unit is declared with
2321       --  an explicit designation of private.
2322
2323       function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
2324          Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
2325
2326       begin
2327          return Private_Present (Comp_Unit);
2328       end Is_Private_Library_Unit;
2329
2330    --  Start of processing for Check_Private_Child_Unit
2331
2332    begin
2333       if Nkind (Lib_Unit) = N_Package_Body
2334         or else Nkind (Lib_Unit) = N_Subprogram_Body
2335       then
2336          Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
2337          Par_Lib   := Curr_Unit;
2338
2339       elsif Nkind (Lib_Unit) = N_Subunit then
2340
2341          --  The parent is itself a body. The parent entity is to be found
2342          --  in the corresponding spec.
2343
2344          Sub_Parent := Library_Unit (N);
2345          Curr_Unit  := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
2346
2347          --  If the parent itself is a subunit, Curr_Unit is the entity
2348          --  of the enclosing body, retrieve the spec entity which is
2349          --  the proper ancestor we need for the following tests.
2350
2351          if Ekind (Curr_Unit) = E_Package_Body then
2352             Curr_Unit := Spec_Entity (Curr_Unit);
2353          end if;
2354
2355          Par_Lib    := Curr_Unit;
2356
2357       else
2358          Curr_Unit := Defining_Entity (Lib_Unit);
2359
2360          Par_Lib := Curr_Unit;
2361          Par_Spec  := Parent_Spec (Lib_Unit);
2362
2363          if No (Par_Spec) then
2364             Par_Lib := Empty;
2365          else
2366             Par_Lib := Defining_Entity (Unit (Par_Spec));
2367          end if;
2368       end if;
2369
2370       --  Loop through context items
2371
2372       Item := First (Context_Items (N));
2373       while Present (Item) loop
2374
2375          --  Ada 2005 (AI-262): Allow private_with of a private child package
2376          --  in public siblings
2377
2378          if Nkind (Item) = N_With_Clause
2379             and then not Implicit_With (Item)
2380             and then not Private_Present (Item)
2381             and then Is_Private_Descendant (Entity (Name (Item)))
2382          then
2383             Priv_Child := Entity (Name (Item));
2384
2385             declare
2386                Curr_Parent  : Entity_Id := Par_Lib;
2387                Child_Parent : Entity_Id := Scope (Priv_Child);
2388                Prv_Ancestor : Entity_Id := Child_Parent;
2389                Curr_Private : Boolean   := Is_Private_Library_Unit (Curr_Unit);
2390
2391             begin
2392                --  If the child unit is a public child then locate
2393                --  the nearest private ancestor; Child_Parent will
2394                --  then be set to the parent of that ancestor.
2395
2396                if not Is_Private_Library_Unit (Priv_Child) then
2397                   while Present (Prv_Ancestor)
2398                     and then not Is_Private_Library_Unit (Prv_Ancestor)
2399                   loop
2400                      Prv_Ancestor := Scope (Prv_Ancestor);
2401                   end loop;
2402
2403                   if Present (Prv_Ancestor) then
2404                      Child_Parent := Scope (Prv_Ancestor);
2405                   end if;
2406                end if;
2407
2408                while Present (Curr_Parent)
2409                  and then Curr_Parent /= Standard_Standard
2410                  and then Curr_Parent /= Child_Parent
2411                loop
2412                   Curr_Private :=
2413                     Curr_Private or else Is_Private_Library_Unit (Curr_Parent);
2414                   Curr_Parent := Scope (Curr_Parent);
2415                end loop;
2416
2417                if not Present (Curr_Parent) then
2418                   Curr_Parent := Standard_Standard;
2419                end if;
2420
2421                if Curr_Parent /= Child_Parent then
2422
2423                   if Ekind (Priv_Child) = E_Generic_Package
2424                     and then Chars (Priv_Child) in Text_IO_Package_Name
2425                     and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
2426                   then
2427                      Error_Msg_NE
2428                        ("& is a nested package, not a compilation unit",
2429                        Name (Item), Priv_Child);
2430
2431                   else
2432                      Error_Msg_N
2433                        ("unit in with clause is private child unit!", Item);
2434                      Error_Msg_NE
2435                        ("current unit must also have parent&!",
2436                         Item, Child_Parent);
2437                   end if;
2438
2439                elsif not Curr_Private
2440                  and then Nkind (Lib_Unit) /= N_Package_Body
2441                  and then Nkind (Lib_Unit) /= N_Subprogram_Body
2442                  and then Nkind (Lib_Unit) /= N_Subunit
2443                then
2444                   Error_Msg_NE
2445                     ("current unit must also be private descendant of&",
2446                      Item, Child_Parent);
2447                end if;
2448             end;
2449          end if;
2450
2451          Next (Item);
2452       end loop;
2453
2454    end Check_Private_Child_Unit;
2455
2456    ----------------------
2457    -- Check_Stub_Level --
2458    ----------------------
2459
2460    procedure Check_Stub_Level (N : Node_Id) is
2461       Par  : constant Node_Id   := Parent (N);
2462       Kind : constant Node_Kind := Nkind (Par);
2463
2464    begin
2465       if (Kind = N_Package_Body
2466            or else Kind = N_Subprogram_Body
2467            or else Kind = N_Task_Body
2468            or else Kind = N_Protected_Body)
2469         and then (Nkind (Parent (Par)) = N_Compilation_Unit
2470                     or else Nkind (Parent (Par)) = N_Subunit)
2471       then
2472          null;
2473
2474       --  In an instance, a missing stub appears at any level. A warning
2475       --  message will have been emitted already for the missing file.
2476
2477       elsif not In_Instance then
2478          Error_Msg_N ("stub cannot appear in an inner scope", N);
2479
2480       elsif Expander_Active then
2481          Error_Msg_N ("missing proper body", N);
2482       end if;
2483    end Check_Stub_Level;
2484
2485    ------------------------
2486    -- Expand_With_Clause --
2487    ------------------------
2488
2489    procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id) is
2490       Loc   : constant Source_Ptr := Sloc (Nam);
2491       Ent   : constant Entity_Id := Entity (Nam);
2492       Withn : Node_Id;
2493       P     : Node_Id;
2494
2495       function Build_Unit_Name (Nam : Node_Id) return Node_Id;
2496       --  Comment requireed here ???
2497
2498       ---------------------
2499       -- Build_Unit_Name --
2500       ---------------------
2501
2502       function Build_Unit_Name (Nam : Node_Id) return Node_Id is
2503          Result : Node_Id;
2504
2505       begin
2506          if Nkind (Nam) = N_Identifier then
2507             return New_Occurrence_Of (Entity (Nam), Loc);
2508
2509          else
2510             Result :=
2511               Make_Expanded_Name (Loc,
2512                 Chars  => Chars (Entity (Nam)),
2513                 Prefix => Build_Unit_Name (Prefix (Nam)),
2514                 Selector_Name => New_Occurrence_Of (Entity (Nam), Loc));
2515             Set_Entity (Result, Entity (Nam));
2516             return Result;
2517          end if;
2518       end Build_Unit_Name;
2519
2520    --  Start of processing for Expand_With_Clause
2521
2522    begin
2523       New_Nodes_OK := New_Nodes_OK + 1;
2524       Withn :=
2525         Make_With_Clause (Loc, Name => Build_Unit_Name (Nam));
2526
2527       P := Parent (Unit_Declaration_Node (Ent));
2528       Set_Library_Unit          (Withn, P);
2529       Set_Corresponding_Spec    (Withn, Ent);
2530       Set_First_Name            (Withn, True);
2531       Set_Implicit_With         (Withn, True);
2532
2533       --  If the unit is a package declaration, a private_with_clause on a
2534       --  child unit implies that the implicit with on the parent is also
2535       --  private.
2536
2537       if Nkind (Unit (N)) = N_Package_Declaration then
2538          Set_Private_Present       (Withn, Private_Present (Item));
2539       end if;
2540
2541       Prepend (Withn, Context_Items (N));
2542       Mark_Rewrite_Insertion (Withn);
2543       Install_Withed_Unit (Withn);
2544
2545       if Nkind (Nam) = N_Expanded_Name then
2546          Expand_With_Clause (Item, Prefix (Nam), N);
2547       end if;
2548
2549       New_Nodes_OK := New_Nodes_OK - 1;
2550    end Expand_With_Clause;
2551
2552    -----------------------
2553    -- Get_Parent_Entity --
2554    -----------------------
2555
2556    function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
2557    begin
2558       if Nkind (Unit) = N_Package_Body
2559         and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
2560       then
2561          return
2562            Defining_Entity
2563              (Specification (Instance_Spec (Original_Node (Unit))));
2564
2565       elsif Nkind (Unit) = N_Package_Instantiation then
2566          return Defining_Entity (Specification (Instance_Spec (Unit)));
2567
2568       else
2569          return Defining_Entity (Unit);
2570       end if;
2571    end Get_Parent_Entity;
2572
2573    -----------------------------
2574    -- Implicit_With_On_Parent --
2575    -----------------------------
2576
2577    procedure Implicit_With_On_Parent
2578      (Child_Unit : Node_Id;
2579       N          : Node_Id)
2580    is
2581       Loc    : constant Source_Ptr := Sloc (N);
2582       P      : constant Node_Id    := Parent_Spec (Child_Unit);
2583
2584       P_Unit : Node_Id    := Unit (P);
2585
2586       P_Name : constant Entity_Id  := Get_Parent_Entity (P_Unit);
2587       Withn  : Node_Id;
2588
2589       function Build_Ancestor_Name (P : Node_Id) return Node_Id;
2590       --  Build prefix of child unit name. Recurse if needed
2591
2592       function Build_Unit_Name return Node_Id;
2593       --  If the unit is a child unit, build qualified name with all
2594       --  ancestors.
2595
2596       -------------------------
2597       -- Build_Ancestor_Name --
2598       -------------------------
2599
2600       function Build_Ancestor_Name (P : Node_Id) return Node_Id is
2601          P_Ref  : constant Node_Id :=
2602                    New_Reference_To (Defining_Entity (P), Loc);
2603          P_Spec : Node_Id := P;
2604
2605       begin
2606          --  Ancestor may have been rewritten as a package body. Retrieve
2607          --  the original spec to trace earlier ancestors.
2608
2609          if Nkind (P) = N_Package_Body
2610            and then Nkind (Original_Node (P)) = N_Package_Instantiation
2611          then
2612             P_Spec := Original_Node (P);
2613          end if;
2614
2615          if No (Parent_Spec (P_Spec)) then
2616             return P_Ref;
2617          else
2618             return
2619               Make_Selected_Component (Loc,
2620                 Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))),
2621                 Selector_Name => P_Ref);
2622          end if;
2623       end Build_Ancestor_Name;
2624
2625       ---------------------
2626       -- Build_Unit_Name --
2627       ---------------------
2628
2629       function Build_Unit_Name return Node_Id is
2630          Result : Node_Id;
2631       begin
2632          if No (Parent_Spec (P_Unit)) then
2633             return New_Reference_To (P_Name, Loc);
2634          else
2635             Result :=
2636               Make_Expanded_Name (Loc,
2637                 Chars  => Chars (P_Name),
2638                 Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
2639                 Selector_Name => New_Reference_To (P_Name, Loc));
2640             Set_Entity (Result, P_Name);
2641             return Result;
2642          end if;
2643       end Build_Unit_Name;
2644
2645    --  Start of processing for Implicit_With_On_Parent
2646
2647    begin
2648       --  The unit of the current compilation may be a package body
2649       --  that replaces an instance node. In this case we need the
2650       --  original instance node to construct the proper parent name.
2651
2652       if Nkind (P_Unit) = N_Package_Body
2653         and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation
2654       then
2655          P_Unit := Original_Node (P_Unit);
2656       end if;
2657
2658       --  We add the implicit with if the child unit is the current unit
2659       --  being compiled. If the current unit is a body, we do not want
2660       --  to add an implicit_with a second time to the corresponding spec.
2661
2662       if Nkind (Child_Unit) = N_Package_Declaration
2663         and then Child_Unit /= Unit (Cunit (Current_Sem_Unit))
2664       then
2665          return;
2666       end if;
2667
2668       New_Nodes_OK := New_Nodes_OK + 1;
2669       Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
2670
2671       Set_Library_Unit          (Withn, P);
2672       Set_Corresponding_Spec    (Withn, P_Name);
2673       Set_First_Name            (Withn, True);
2674       Set_Implicit_With         (Withn, True);
2675
2676       --  Node is placed at the beginning of the context items, so that
2677       --  subsequent use clauses on the parent can be validated.
2678
2679       Prepend (Withn, Context_Items (N));
2680       Mark_Rewrite_Insertion (Withn);
2681       Install_Withed_Unit (Withn);
2682
2683       if Is_Child_Spec (P_Unit) then
2684          Implicit_With_On_Parent (P_Unit, N);
2685       end if;
2686
2687       New_Nodes_OK := New_Nodes_OK - 1;
2688    end Implicit_With_On_Parent;
2689
2690    --------------
2691    -- In_Chain --
2692    --------------
2693
2694    function In_Chain (E : Entity_Id) return Boolean is
2695       H : Entity_Id;
2696
2697    begin
2698       H := Current_Entity (E);
2699       while Present (H) loop
2700          if H = E then
2701             return True;
2702          else
2703             H := Homonym (H);
2704          end if;
2705       end loop;
2706
2707       return False;
2708    end In_Chain;
2709
2710    ---------------------
2711    -- Install_Context --
2712    ---------------------
2713
2714    procedure Install_Context (N : Node_Id) is
2715       Lib_Unit : constant Node_Id := Unit (N);
2716
2717    begin
2718       Install_Context_Clauses (N);
2719
2720       if Is_Child_Spec (Lib_Unit) then
2721          Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
2722       end if;
2723
2724       Install_Limited_Context_Clauses (N);
2725
2726       Check_With_Type_Clauses (N);
2727    end Install_Context;
2728
2729    -----------------------------
2730    -- Install_Context_Clauses --
2731    -----------------------------
2732
2733    procedure Install_Context_Clauses (N : Node_Id) is
2734       Lib_Unit      : constant Node_Id := Unit (N);
2735       Item          : Node_Id;
2736       Uname_Node    : Entity_Id;
2737       Check_Private : Boolean := False;
2738       Decl_Node     : Node_Id;
2739       Lib_Parent    : Entity_Id;
2740
2741    begin
2742       --  Loop through context clauses to find the with/use clauses.
2743       --  This is done twice, first for everything except limited_with
2744       --  clauses, and then for those, if any are present.
2745
2746       Item := First (Context_Items (N));
2747       while Present (Item) loop
2748
2749          --  Case of explicit WITH clause
2750
2751          if Nkind (Item) = N_With_Clause
2752            and then not Implicit_With (Item)
2753          then
2754             if Limited_Present (Item) then
2755
2756                --  Limited withed units will be installed later
2757
2758                goto Continue;
2759
2760             --  If Name (Item) is not an entity name, something is wrong, and
2761             --  this will be detected in due course, for now ignore the item
2762
2763             elsif not Is_Entity_Name (Name (Item)) then
2764                goto Continue;
2765
2766             elsif No (Entity (Name (Item))) then
2767                Set_Entity (Name (Item), Any_Id);
2768                goto Continue;
2769             end if;
2770
2771             Uname_Node := Entity (Name (Item));
2772
2773             if Is_Private_Descendant (Uname_Node) then
2774                Check_Private := True;
2775             end if;
2776
2777             Install_Withed_Unit (Item);
2778
2779             Decl_Node := Unit_Declaration_Node (Uname_Node);
2780
2781             --  If the unit is a subprogram instance, it appears nested
2782             --  within a package that carries the parent information.
2783
2784             if Is_Generic_Instance (Uname_Node)
2785               and then Ekind (Uname_Node) /= E_Package
2786             then
2787                Decl_Node := Parent (Parent (Decl_Node));
2788             end if;
2789
2790             if Is_Child_Spec (Decl_Node) then
2791                if Nkind (Name (Item)) = N_Expanded_Name then
2792                   Expand_With_Clause (Item, Prefix (Name (Item)), N);
2793                else
2794                   --  if not an expanded name, the child unit must be a
2795                   --  renaming, nothing to do.
2796
2797                   null;
2798                end if;
2799
2800             elsif Nkind (Decl_Node) = N_Subprogram_Body
2801               and then not Acts_As_Spec (Parent (Decl_Node))
2802               and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node))))
2803             then
2804                Implicit_With_On_Parent
2805                  (Unit (Library_Unit (Parent (Decl_Node))), N);
2806             end if;
2807
2808             --  Check license conditions unless this is a dummy unit
2809
2810             if Sloc (Library_Unit (Item)) /= No_Location then
2811                License_Check : declare
2812
2813                   Withu : constant Unit_Number_Type :=
2814                             Get_Source_Unit (Library_Unit (Item));
2815
2816                   Withl : constant License_Type :=
2817                             License (Source_Index (Withu));
2818
2819                   Unitl : constant License_Type :=
2820                            License (Source_Index (Current_Sem_Unit));
2821
2822                   procedure License_Error;
2823                   --  Signal error of bad license
2824
2825                   -------------------
2826                   -- License_Error --
2827                   -------------------
2828
2829                   procedure License_Error is
2830                   begin
2831                      Error_Msg_N
2832                        ("?license of with'ed unit & may be inconsistent",
2833                         Name (Item));
2834                   end License_Error;
2835
2836                --  Start of processing for License_Check
2837
2838                begin
2839                   --  Exclude license check if withed unit is an internal unit.
2840                   --  This situation arises e.g. with the GPL version of GNAT.
2841
2842                   if Is_Internal_File_Name (Unit_File_Name (Withu)) then
2843                      null;
2844
2845                      --  Otherwise check various cases
2846                   else
2847                      case Unitl is
2848                         when Unknown =>
2849                            null;
2850
2851                         when Restricted =>
2852                            if Withl = GPL then
2853                               License_Error;
2854                            end if;
2855
2856                         when GPL =>
2857                            if Withl = Restricted then
2858                               License_Error;
2859                            end if;
2860
2861                         when Modified_GPL =>
2862                            if Withl = Restricted or else Withl = GPL then
2863                               License_Error;
2864                            end if;
2865
2866                         when Unrestricted =>
2867                            null;
2868                      end case;
2869                   end if;
2870                end License_Check;
2871             end if;
2872
2873          --  Case of USE PACKAGE clause
2874
2875          elsif Nkind (Item) = N_Use_Package_Clause then
2876             Analyze_Use_Package (Item);
2877
2878          --  Case of USE TYPE clause
2879
2880          elsif Nkind (Item) = N_Use_Type_Clause then
2881             Analyze_Use_Type (Item);
2882
2883          --  Case of WITH TYPE clause
2884
2885          --  A With_Type_Clause is processed when installing the context,
2886          --  because it is a visibility mechanism and does not create a
2887          --  semantic dependence on other units, as a With_Clause does.
2888
2889          elsif Nkind (Item) = N_With_Type_Clause then
2890             Analyze_With_Type_Clause (Item);
2891
2892          --  case of PRAGMA
2893
2894          elsif Nkind (Item) = N_Pragma then
2895             Analyze (Item);
2896          end if;
2897
2898       <<Continue>>
2899          Next (Item);
2900       end loop;
2901
2902       if Is_Child_Spec (Lib_Unit) then
2903
2904          --  The unit also has implicit withs on its own parents
2905
2906          if No (Context_Items (N)) then
2907             Set_Context_Items (N, New_List);
2908          end if;
2909
2910          Implicit_With_On_Parent (Lib_Unit, N);
2911       end if;
2912
2913       --  If the unit is a body, the context of the specification must also
2914       --  be installed.
2915
2916       if Nkind (Lib_Unit) = N_Package_Body
2917         or else (Nkind (Lib_Unit) = N_Subprogram_Body
2918                    and then not Acts_As_Spec (N))
2919       then
2920          Install_Context (Library_Unit (N));
2921
2922          if Is_Child_Spec (Unit (Library_Unit (N))) then
2923
2924             --  If the unit is the body of a public child unit, the private
2925             --  declarations of the parent must be made visible. If the child
2926             --  unit is private, the private declarations have been installed
2927             --  already in the call to Install_Parents for the spec. Installing
2928             --  private declarations must be done for all ancestors of public
2929             --  child units. In addition, sibling units mentioned in the
2930             --  context clause of the body are directly visible.
2931
2932             declare
2933                Lib_Spec : Node_Id;
2934                P        : Node_Id;
2935                P_Name   : Entity_Id;
2936
2937             begin
2938                Lib_Spec := Unit (Library_Unit (N));
2939                while Is_Child_Spec (Lib_Spec) loop
2940                   P      := Unit (Parent_Spec (Lib_Spec));
2941                   P_Name := Defining_Entity (P);
2942
2943                   if not (Private_Present (Parent (Lib_Spec)))
2944                     and then not In_Private_Part (P_Name)
2945                   then
2946                      Install_Private_Declarations (P_Name);
2947                      Install_Private_With_Clauses (P_Name);
2948                      Set_Use (Private_Declarations (Specification (P)));
2949                   end if;
2950
2951                   Lib_Spec := P;
2952                end loop;
2953             end;
2954          end if;
2955
2956          --  For a package body, children in context are immediately visible
2957
2958          Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
2959       end if;
2960
2961       if Nkind (Lib_Unit) = N_Generic_Package_Declaration
2962         or else Nkind (Lib_Unit) = N_Generic_Subprogram_Declaration
2963         or else Nkind (Lib_Unit) = N_Package_Declaration
2964         or else Nkind (Lib_Unit) = N_Subprogram_Declaration
2965       then
2966          if Is_Child_Spec (Lib_Unit) then
2967             Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
2968             Set_Is_Private_Descendant
2969               (Defining_Entity (Lib_Unit),
2970                Is_Private_Descendant (Lib_Parent)
2971                  or else Private_Present (Parent (Lib_Unit)));
2972
2973          else
2974             Set_Is_Private_Descendant
2975               (Defining_Entity (Lib_Unit),
2976                Private_Present (Parent (Lib_Unit)));
2977          end if;
2978       end if;
2979
2980       if Check_Private then
2981          Check_Private_Child_Unit (N);
2982       end if;
2983    end Install_Context_Clauses;
2984
2985    -------------------------------------
2986    -- Install_Limited_Context_Clauses --
2987    -------------------------------------
2988
2989    procedure Install_Limited_Context_Clauses (N : Node_Id) is
2990       Item : Node_Id;
2991
2992       procedure Check_Renamings (P : Node_Id; W : Node_Id);
2993       --  Check that the unlimited view of a given compilation_unit is not
2994       --  already visible through "use + renamings".
2995
2996       procedure Check_Private_Limited_Withed_Unit (N : Node_Id);
2997       --  Check that if a limited_with clause of a given compilation_unit
2998       --  mentions a private child of some library unit, then the given
2999       --  compilation_unit shall be the declaration of a private descendant
3000       --  of that library unit.
3001
3002       procedure Expand_Limited_With_Clause
3003         (Comp_Unit : Node_Id; Nam : Node_Id; N : Node_Id);
3004       --  If a child unit appears in a limited_with clause, there are implicit
3005       --  limited_with clauses on all parents that are not already visible
3006       --  through a regular with clause. This procedure creates the implicit
3007       --  limited with_clauses for the parents and loads the corresponding
3008       --  units. The shadow entities are created when the inserted clause is
3009       --  analyzed. Implements Ada 2005 (AI-50217).
3010
3011       ---------------------
3012       -- Check_Renamings --
3013       ---------------------
3014
3015       procedure Check_Renamings (P : Node_Id; W : Node_Id) is
3016          Item   : Node_Id;
3017          Spec   : Node_Id;
3018          WEnt   : Entity_Id;
3019          Nam    : Node_Id;
3020          E      : Entity_Id;
3021          E2     : Entity_Id;
3022
3023       begin
3024          pragma Assert (Nkind (W) = N_With_Clause);
3025
3026          --  Protect the frontend against previous critical errors
3027
3028          case Nkind (Unit (Library_Unit (W))) is
3029             when N_Subprogram_Declaration         |
3030                  N_Package_Declaration            |
3031                  N_Generic_Subprogram_Declaration |
3032                  N_Generic_Package_Declaration    =>
3033                null;
3034
3035             when others =>
3036                return;
3037          end case;
3038
3039          --  Check "use + renamings"
3040
3041          WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W))));
3042          Spec := Specification (Unit (P));
3043
3044          Item := First (Visible_Declarations (Spec));
3045          while Present (Item) loop
3046
3047             if Nkind (Item) = N_Use_Package_Clause then
3048
3049                --  Traverse the list of packages
3050
3051                Nam := First (Names (Item));
3052                while Present (Nam) loop
3053                   E := Entity (Nam);
3054
3055                   pragma Assert (Present (Parent (E)));
3056
3057                   if Nkind (Parent (E)) = N_Package_Renaming_Declaration
3058                     and then Renamed_Entity (E) = WEnt
3059                   then
3060                      Error_Msg_N ("unlimited view visible through " &
3061                                   "use clause and renamings", W);
3062                      return;
3063
3064                   elsif Nkind (Parent (E)) = N_Package_Specification then
3065
3066                      --  The use clause may refer to a local package.
3067                      --  Check all the enclosing scopes.
3068
3069                      E2 := E;
3070                      while E2 /= Standard_Standard
3071                        and then E2 /= WEnt loop
3072                         E2 := Scope (E2);
3073                      end loop;
3074
3075                      if E2 = WEnt then
3076                         Error_Msg_N
3077                           ("unlimited view visible through use clause ", W);
3078                         return;
3079                      end if;
3080
3081                   end if;
3082                   Next (Nam);
3083                end loop;
3084
3085             end if;
3086
3087             Next (Item);
3088          end loop;
3089
3090          --  Recursive call to check all the ancestors
3091
3092          if Is_Child_Spec (Unit (P)) then
3093             Check_Renamings (P => Parent_Spec (Unit (P)), W => W);
3094          end if;
3095       end Check_Renamings;
3096
3097       ---------------------------------------
3098       -- Check_Private_Limited_Withed_Unit --
3099       ---------------------------------------
3100
3101       procedure Check_Private_Limited_Withed_Unit (N : Node_Id) is
3102          C     : Node_Id;
3103          P     : Node_Id;
3104          Found : Boolean := False;
3105
3106       begin
3107          --  If the current compilation unit is not private we don't
3108          --  need to check anything else.
3109
3110          if not Private_Present (Parent (N)) then
3111             Found := False;
3112
3113          else
3114             --  Compilation unit of the parent of the withed library unit
3115
3116             P := Parent_Spec (Unit (Library_Unit (N)));
3117
3118             --  Traverse all the ancestors of the current compilation
3119             --  unit to check if it is a descendant of named library unit.
3120
3121             C := Parent (N);
3122             while Present (Parent_Spec (Unit (C))) loop
3123                C := Parent_Spec (Unit (C));
3124
3125                if C = P then
3126                   Found := True;
3127                   exit;
3128                end if;
3129             end loop;
3130          end if;
3131
3132          if not Found then
3133             Error_Msg_N ("current unit is not a private descendant"
3134                          & " of the withed unit ('R'M 10.1.2(8)", N);
3135          end if;
3136       end Check_Private_Limited_Withed_Unit;
3137
3138       --------------------------------
3139       -- Expand_Limited_With_Clause --
3140       --------------------------------
3141
3142       procedure Expand_Limited_With_Clause
3143         (Comp_Unit : Node_Id;
3144          Nam       : Node_Id;
3145          N         : Node_Id)
3146       is
3147          Loc   : constant Source_Ptr := Sloc (Nam);
3148          Unum  : Unit_Number_Type;
3149          Withn : Node_Id;
3150
3151          function Previous_Withed_Unit (W : Node_Id) return Boolean;
3152          --  Returns true if the context already includes a with_clause for
3153          --  this unit. If the with_clause is non-limited, the unit is fully
3154          --  visible and an implicit limited_with should not be created. If
3155          --  there is already a limited_with clause for W, a second one is
3156          --  simply redundant.
3157
3158          --------------------------
3159          -- Previous_Withed_Unit --
3160          --------------------------
3161
3162          function Previous_Withed_Unit (W : Node_Id) return Boolean is
3163             Item : Node_Id;
3164
3165          begin
3166             --  A limited with_clause cannot appear in the same context_clause
3167             --  as a nonlimited with_clause which mentions the same library.
3168
3169             Item := First (Context_Items (Comp_Unit));
3170             while Present (Item) loop
3171                if Nkind (Item) = N_With_Clause
3172                  and then Library_Unit (Item) = Library_Unit (W)
3173                then
3174                   return True;
3175                end if;
3176
3177                Next (Item);
3178             end loop;
3179
3180             return False;
3181          end Previous_Withed_Unit;
3182
3183       --  Start of processing for Expand_Limited_With_Clause
3184
3185       begin
3186          New_Nodes_OK := New_Nodes_OK + 1;
3187
3188          if Nkind (Nam) = N_Identifier then
3189             Withn :=
3190               Make_With_Clause (Loc,
3191                 Name => Nam);
3192
3193          else pragma Assert (Nkind (Nam) = N_Selected_Component);
3194             Withn :=
3195               Make_With_Clause (Loc,
3196                 Name => Make_Selected_Component (Loc,
3197                   Prefix        => Prefix (Nam),
3198                   Selector_Name => Selector_Name (Nam)));
3199             Set_Parent (Withn, Parent (N));
3200          end if;
3201
3202          Set_Limited_Present (Withn);
3203          Set_First_Name      (Withn);
3204          Set_Implicit_With   (Withn);
3205
3206          Unum :=
3207            Load_Unit
3208              (Load_Name  => Get_Spec_Name (Get_Unit_Name (Nam)),
3209               Required   => True,
3210               Subunit    => False,
3211               Error_Node => Nam);
3212
3213          --  Do not generate a limited_with_clause on the current unit.
3214          --  This path is taken when a unit has a limited_with clause on
3215          --  one of its child units.
3216
3217          if Unum = Current_Sem_Unit then
3218             return;
3219          end if;
3220
3221          Set_Library_Unit (Withn, Cunit (Unum));
3222          Set_Corresponding_Spec
3223            (Withn, Specification (Unit (Cunit (Unum))));
3224
3225          if not Previous_Withed_Unit (Withn) then
3226             Prepend (Withn, Context_Items (Parent (N)));
3227             Mark_Rewrite_Insertion (Withn);
3228
3229             --  Add implicit limited_with_clauses for parents of child units
3230             --  mentioned in limited_with clauses.
3231
3232             if Nkind (Nam) = N_Selected_Component then
3233                Expand_Limited_With_Clause (Comp_Unit, Prefix (Nam), N);
3234             end if;
3235
3236             Analyze (Withn);
3237
3238             if not Limited_View_Installed (Withn) then
3239                Install_Limited_Withed_Unit (Withn);
3240             end if;
3241          end if;
3242
3243          New_Nodes_OK := New_Nodes_OK - 1;
3244       end Expand_Limited_With_Clause;
3245
3246    --  Start of processing for Install_Limited_Context_Clauses
3247
3248    begin
3249       Item := First (Context_Items (N));
3250       while Present (Item) loop
3251          if Nkind (Item) = N_With_Clause
3252            and then Limited_Present (Item)
3253          then
3254             if Nkind (Name (Item)) = N_Selected_Component then
3255                Expand_Limited_With_Clause
3256                  (Comp_Unit => N, Nam => Prefix (Name (Item)), N => Item);
3257             end if;
3258
3259             if Private_Present (Library_Unit (Item)) then
3260                Check_Private_Limited_Withed_Unit (Item);
3261             end if;
3262
3263             if not Implicit_With (Item)
3264               and then Is_Child_Spec (Unit (N))
3265             then
3266                Check_Renamings (Parent_Spec (Unit (N)), Item);
3267             end if;
3268
3269             --  A unit may have a limited with on itself if it has a
3270             --  limited with_clause on one of its child units. In that
3271             --  case it is already being compiled and it makes no sense
3272             --  to install its limited view.
3273
3274             if Library_Unit (Item) /= Cunit (Current_Sem_Unit)
3275               and then not Limited_View_Installed (Item)
3276             then
3277                Install_Limited_Withed_Unit (Item);
3278             end if;
3279          end if;
3280
3281          Next (Item);
3282       end loop;
3283    end Install_Limited_Context_Clauses;
3284
3285    ---------------------
3286    -- Install_Parents --
3287    ---------------------
3288
3289    procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
3290       P      : Node_Id;
3291       E_Name : Entity_Id;
3292       P_Name : Entity_Id;
3293       P_Spec : Node_Id;
3294
3295    begin
3296       P := Unit (Parent_Spec (Lib_Unit));
3297       P_Name := Get_Parent_Entity (P);
3298
3299       if Etype (P_Name) = Any_Type then
3300          return;
3301       end if;
3302
3303       if Ekind (P_Name) = E_Generic_Package
3304         and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
3305         and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
3306         and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
3307       then
3308          Error_Msg_N
3309            ("child of a generic package must be a generic unit", Lib_Unit);
3310
3311       elsif not Is_Package_Or_Generic_Package (P_Name) then
3312          Error_Msg_N
3313            ("parent unit must be package or generic package", Lib_Unit);
3314          raise Unrecoverable_Error;
3315
3316       elsif Present (Renamed_Object (P_Name)) then
3317          Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
3318          raise Unrecoverable_Error;
3319
3320       --  Verify that a child of an instance is itself an instance, or
3321       --  the renaming of one. Given that an instance that is a unit is
3322       --  replaced with a package declaration, check against the original
3323       --  node. The parent may be currently being instantiated, in which
3324       --  case it appears as a declaration, but the generic_parent is
3325       --  already established indicating that we deal with an instance.
3326
3327       elsif Nkind (Original_Node (P)) = N_Package_Instantiation then
3328
3329          if Nkind (Lib_Unit) in N_Renaming_Declaration
3330            or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation
3331            or else
3332              (Nkind (Lib_Unit) = N_Package_Declaration
3333                 and then Present (Generic_Parent (Specification (Lib_Unit))))
3334          then
3335             null;
3336          else
3337             Error_Msg_N
3338               ("child of an instance must be an instance or renaming",
3339                 Lib_Unit);
3340          end if;
3341       end if;
3342
3343       --  This is the recursive call that ensures all parents are loaded
3344
3345       if Is_Child_Spec (P) then
3346          Install_Parents (P,
3347            Is_Private or else Private_Present (Parent (Lib_Unit)));
3348       end if;
3349
3350       --  Now we can install the context for this parent
3351
3352       Install_Context_Clauses (Parent_Spec (Lib_Unit));
3353       Install_Siblings (P_Name, Parent (Lib_Unit));
3354
3355       --  The child unit is in the declarative region of the parent. The
3356       --  parent must therefore appear in the scope stack and be visible,
3357       --  as when compiling the corresponding body. If the child unit is
3358       --  private or it is a package body, private declarations must be
3359       --  accessible as well. Use declarations in the parent must also
3360       --  be installed. Finally, other child units of the same parent that
3361       --  are in the context are immediately visible.
3362
3363       --  Find entity for compilation unit, and set its private descendant
3364       --  status as needed.
3365
3366       E_Name := Defining_Entity (Lib_Unit);
3367
3368       Set_Is_Child_Unit (E_Name);
3369
3370       Set_Is_Private_Descendant (E_Name,
3371          Is_Private_Descendant (P_Name)
3372            or else Private_Present (Parent (Lib_Unit)));
3373
3374       P_Spec := Specification (Unit_Declaration_Node (P_Name));
3375       New_Scope (P_Name);
3376
3377       --  Save current visibility of unit
3378
3379       Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
3380         Is_Immediately_Visible (P_Name);
3381       Set_Is_Immediately_Visible (P_Name);
3382       Install_Visible_Declarations (P_Name);
3383       Set_Use (Visible_Declarations (P_Spec));
3384
3385       --  If the parent is a generic unit, its formal part may contain
3386       --  formal packages and use clauses for them.
3387
3388       if Ekind (P_Name) = E_Generic_Package then
3389          Set_Use (Generic_Formal_Declarations (Parent (P_Spec)));
3390       end if;
3391
3392       if Is_Private
3393         or else Private_Present (Parent (Lib_Unit))
3394       then
3395          Install_Private_Declarations (P_Name);
3396          Install_Private_With_Clauses (P_Name);
3397          Set_Use (Private_Declarations (P_Spec));
3398       end if;
3399    end Install_Parents;
3400
3401    ----------------------------------
3402    -- Install_Private_With_Clauses --
3403    ----------------------------------
3404
3405    procedure Install_Private_With_Clauses (P : Entity_Id) is
3406       Decl   : constant Node_Id := Unit_Declaration_Node (P);
3407       Item   : Node_Id;
3408
3409    begin
3410       if Debug_Flag_I then
3411          Write_Str ("install private with clauses of ");
3412          Write_Name (Chars (P));
3413          Write_Eol;
3414       end if;
3415
3416       if Nkind (Parent (Decl)) = N_Compilation_Unit then
3417          Item := First (Context_Items (Parent (Decl)));
3418          while Present (Item) loop
3419             if Nkind (Item) = N_With_Clause
3420               and then Private_Present (Item)
3421             then
3422                if Limited_Present (Item) then
3423                   if not Limited_View_Installed (Item) then
3424                      Install_Limited_Withed_Unit (Item);
3425                   end if;
3426                else
3427                   Install_Withed_Unit (Item, Private_With_OK => True);
3428                end if;
3429             end if;
3430
3431             Next (Item);
3432          end loop;
3433       end if;
3434    end Install_Private_With_Clauses;
3435
3436    ----------------------
3437    -- Install_Siblings --
3438    ----------------------
3439
3440    procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
3441       Item : Node_Id;
3442       Id   : Entity_Id;
3443       Prev : Entity_Id;
3444    begin
3445       --  Iterate over explicit with clauses, and check whether the
3446       --  scope of each entity is an ancestor of the current unit.
3447
3448       Item := First (Context_Items (N));
3449       while Present (Item) loop
3450
3451          --  Do not install private_with_clauses if the unit is a package
3452          --  declaration, unless it is itself a private child unit.
3453
3454          if Nkind (Item) = N_With_Clause
3455            and then not Implicit_With (Item)
3456            and then not Limited_Present (Item)
3457            and then
3458               (not Private_Present (Item)
3459                  or else Nkind (Unit (N)) /= N_Package_Declaration
3460                  or else Private_Present (N))
3461          then
3462             Id := Entity (Name (Item));
3463
3464             if Is_Child_Unit (Id)
3465               and then Is_Ancestor_Package (Scope (Id), U_Name)
3466             then
3467                Set_Is_Immediately_Visible (Id);
3468
3469                --  Check for the presence of another unit in the context,
3470                --  that may be inadvertently hidden by the child.
3471
3472                Prev := Current_Entity (Id);
3473
3474                if Present (Prev)
3475                  and then Is_Immediately_Visible (Prev)
3476                  and then not Is_Child_Unit (Prev)
3477                then
3478                   declare
3479                      Clause : Node_Id;
3480
3481                   begin
3482                      Clause := First (Context_Items (N));
3483                      while Present (Clause) loop
3484                         if Nkind (Clause) = N_With_Clause
3485                           and then Entity (Name (Clause)) = Prev
3486                         then
3487                            Error_Msg_NE
3488                               ("child unit& hides compilation unit " &
3489                                "with the same name?",
3490                                  Name (Item), Id);
3491                            exit;
3492                         end if;
3493
3494                         Next (Clause);
3495                      end loop;
3496                   end;
3497                end if;
3498
3499             --  the With_Clause may be on a grand-child, which makes
3500             --  the child immediately visible.
3501
3502             elsif Is_Child_Unit (Scope (Id))
3503               and then Is_Ancestor_Package (Scope (Scope (Id)), U_Name)
3504             then
3505                Set_Is_Immediately_Visible (Scope (Id));
3506             end if;
3507          end if;
3508
3509          Next (Item);
3510       end loop;
3511    end Install_Siblings;
3512
3513    -------------------------------
3514    -- Install_Limited_With_Unit --
3515    -------------------------------
3516
3517    procedure Install_Limited_Withed_Unit (N : Node_Id) is
3518       P_Unit           : constant Entity_Id := Unit (Library_Unit (N));
3519       P                : Entity_Id;
3520       Is_Child_Package : Boolean := False;
3521
3522       Lim_Header : Entity_Id;
3523       Lim_Typ    : Entity_Id;
3524
3525       function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean;
3526       --  Check if some package installed though normal with-clauses has a
3527       --  renaming declaration of package P. AARM 10.1.2(21/2).
3528
3529       ----------------------------------
3530       -- Is_Visible_Through_Renamings --
3531       ----------------------------------
3532
3533       function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is
3534          Kind     : constant Node_Kind :=
3535                       Nkind (Unit (Cunit (Current_Sem_Unit)));
3536          Aux_Unit : Node_Id;
3537          Item     : Node_Id;
3538          Decl     : Entity_Id;
3539
3540       begin
3541          --  Example of the error detected by this subprogram:
3542
3543          --  package P is
3544          --    type T is ...
3545          --  end P;
3546
3547          --  with P;
3548          --  package Q is
3549          --     package Ren_P renames P;
3550          --  end Q;
3551
3552          --  with Q;
3553          --  package R is ...
3554
3555          --  limited with P; -- ERROR
3556          --  package R.C is ...
3557
3558          Aux_Unit := Cunit (Current_Sem_Unit);
3559          loop
3560             Item := First (Context_Items (Aux_Unit));
3561             while Present (Item) loop
3562                if Nkind (Item) = N_With_Clause
3563                  and then not Limited_Present (Item)
3564                  and then Nkind (Unit (Library_Unit (Item)))
3565                             = N_Package_Declaration
3566                then
3567                   Decl :=
3568                     First (Visible_Declarations
3569                             (Specification (Unit (Library_Unit (Item)))));
3570                   while Present (Decl) loop
3571                      if Nkind (Decl) = N_Package_Renaming_Declaration
3572                        and then Entity (Name (Decl)) = P
3573                      then
3574                         --  Generate the error message only if the current unit
3575                         --  is a package declaration; in case of subprogram
3576                         --  bodies and package bodies we just return true to
3577                         --  indicate that the limited view must not be
3578                         --  installed.
3579
3580                         if Kind = N_Package_Declaration then
3581                            Error_Msg_Sloc := Sloc (Item);
3582                            Error_Msg_NE
3583                              ("unlimited view of & visible through the context"
3584                               & " clause found #", N, P);
3585
3586                            Error_Msg_Sloc := Sloc (Decl);
3587                            Error_Msg_NE
3588                              ("unlimited view of & visible through the"
3589                               & " renaming found #", N, P);
3590
3591                            Error_Msg_N
3592                              ("simultaneous visibility of the limited and"
3593                               & " unlimited views not allowed", N);
3594                         end if;
3595
3596                         return True;
3597                      end if;
3598
3599                      Next (Decl);
3600                   end loop;
3601                end if;
3602
3603                Next (Item);
3604             end loop;
3605
3606             if Present (Library_Unit (Aux_Unit)) then
3607                Aux_Unit := Library_Unit (Aux_Unit);
3608             else
3609                Aux_Unit := Parent_Spec (Unit (Aux_Unit));
3610             end if;
3611
3612             exit when not Present (Aux_Unit);
3613          end loop;
3614
3615          return False;
3616       end Is_Visible_Through_Renamings;
3617
3618    --  Start of processing for Install_Limited_Withed_Unit
3619
3620    begin
3621       pragma Assert (not Limited_View_Installed (N));
3622
3623       --  In case of limited with_clause on subprograms, generics, instances,
3624       --  or renamings, the corresponding error was previously posted and we
3625       --  have nothing to do here.
3626
3627       if Nkind (P_Unit) /= N_Package_Declaration then
3628          return;
3629       end if;
3630
3631       P := Defining_Unit_Name (Specification (P_Unit));
3632
3633       --  Handle child packages
3634
3635       if Nkind (P) = N_Defining_Program_Unit_Name then
3636          Is_Child_Package := True;
3637          P := Defining_Identifier (P);
3638       end if;
3639
3640       --  Do not install the limited-view if the full-view is already visible
3641       --  through renaming declarations.
3642
3643       if Is_Visible_Through_Renamings (P) then
3644          return;
3645       end if;
3646
3647       --  A common use of the limited-with is to have a limited-with
3648       --  in the package spec, and a normal with in its package body.
3649       --  For example:
3650
3651       --       limited with X;  -- [1]
3652       --       package A is ...
3653
3654       --       with X;          -- [2]
3655       --       package body A is ...
3656
3657       --  The compilation of A's body installs the context clauses found at [2]
3658       --  and then the context clauses of its specification (found at [1]). As
3659       --  a consequence, at [1] the specification of X has been analyzed and it
3660       --  is immediately visible. According to the semantics of limited-with
3661       --  context clauses we don't install the limited view because the full
3662       --  view of X supersedes its limited view.
3663
3664       if Analyzed (P_Unit)
3665         and then (Is_Immediately_Visible (P)
3666                     or else (Is_Child_Package
3667                                and then Is_Visible_Child_Unit (P)))
3668       then
3669          --  Ada 2005 (AI-262): Install the private declarations of P
3670
3671          if Private_Present (N)
3672            and then not In_Private_Part (P)
3673          then
3674             declare
3675                Id : Entity_Id;
3676
3677             begin
3678                Id := First_Private_Entity (P);
3679                while Present (Id) loop
3680                   if not Is_Internal (Id)
3681                     and then not Is_Child_Unit (Id)
3682                   then
3683                      if not In_Chain (Id) then
3684                         Set_Homonym (Id, Current_Entity (Id));
3685                         Set_Current_Entity (Id);
3686                      end if;
3687
3688                      Set_Is_Immediately_Visible (Id);
3689                   end if;
3690
3691                   Next_Entity (Id);
3692                end loop;
3693
3694                Set_In_Private_Part (P);
3695             end;
3696          end if;
3697
3698          return;
3699       end if;
3700
3701       if Debug_Flag_I then
3702          Write_Str ("install limited view of ");
3703          Write_Name (Chars (P));
3704          Write_Eol;
3705       end if;
3706
3707       --  If the unit has not been analyzed and the limited view has not been
3708       --  already installed then we install it.
3709
3710       if not Analyzed (P_Unit) then
3711          if not In_Chain (P) then
3712
3713             --  Minimum decoration
3714
3715             Set_Ekind (P, E_Package);
3716             Set_Etype (P, Standard_Void_Type);
3717             Set_Scope (P, Standard_Standard);
3718
3719             if Is_Child_Package then
3720                Set_Is_Child_Unit (P);
3721                Set_Is_Visible_Child_Unit (P);
3722                Set_Scope (P, Defining_Entity (Unit (Parent_Spec (P_Unit))));
3723             end if;
3724
3725             --  Place entity on visibility structure
3726
3727             Set_Homonym (P, Current_Entity (P));
3728             Set_Current_Entity (P);
3729
3730             if Debug_Flag_I then
3731                Write_Str ("   (homonym) chain ");
3732                Write_Name (Chars (P));
3733                Write_Eol;
3734             end if;
3735
3736             --  Install the incomplete view. The first element of the limited
3737             --  view is a header (an E_Package entity) used to reference the
3738             --  first shadow entity in the private part of the package.
3739
3740             Lim_Header := Limited_View (P);
3741             Lim_Typ    := First_Entity (Lim_Header);
3742
3743             while Present (Lim_Typ)
3744               and then Lim_Typ /= First_Private_Entity (Lim_Header)
3745             loop
3746                Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
3747                Set_Current_Entity (Lim_Typ);
3748
3749                if Debug_Flag_I then
3750                   Write_Str ("   (homonym) chain ");
3751                   Write_Name (Chars (Lim_Typ));
3752                   Write_Eol;
3753                end if;
3754
3755                Next_Entity (Lim_Typ);
3756             end loop;
3757          end if;
3758
3759       --  If the unit appears in a previous regular with_clause, the regular
3760       --  entities of the public part of the withed package must be replaced
3761       --  by the shadow ones.
3762
3763       --  This code must be kept synchronized with the code that replaces the
3764       --  the shadow entities by the real entities (see body of Remove_Limited
3765       --  With_Clause); otherwise the contents of the homonym chains are not
3766       --  consistent.
3767
3768       else
3769          --  Hide all the type entities of the public part of the package to
3770          --  avoid its usage. This is needed to cover all the subtype decla-
3771          --  rations because we do not remove them from the homonym chain.
3772
3773          declare
3774             E : Entity_Id;
3775
3776          begin
3777             E := First_Entity (P);
3778             while Present (E) and then E /= First_Private_Entity (P) loop
3779                if Is_Type (E) then
3780                   Set_Was_Hidden (E, Is_Hidden (E));
3781                   Set_Is_Hidden (E);
3782                end if;
3783
3784                Next_Entity (E);
3785             end loop;
3786          end;
3787
3788          --  Replace the real entities by the shadow entities of the limited
3789          --  view. The first element of the limited view is a header that is
3790          --  used to reference the first shadow entity in the private part
3791          --  of the package.
3792
3793          Lim_Header := Limited_View (P);
3794
3795          Lim_Typ := First_Entity (Lim_Header);
3796          while Present (Lim_Typ)
3797            and then Lim_Typ /= First_Private_Entity (Lim_Header)
3798          loop
3799             pragma Assert (not In_Chain (Lim_Typ));
3800
3801             --  Do not unchain child units
3802
3803             if not Is_Child_Unit (Lim_Typ) then
3804                declare
3805                   Prev : Entity_Id;
3806
3807                begin
3808                   Set_Homonym (Lim_Typ, Homonym (Non_Limited_View (Lim_Typ)));
3809                   Prev := Current_Entity (Lim_Typ);
3810
3811                   if Prev = Non_Limited_View (Lim_Typ) then
3812                      Set_Current_Entity (Lim_Typ);
3813                   else
3814                      while Present (Prev)
3815                        and then Homonym (Prev) /= Non_Limited_View (Lim_Typ)
3816                      loop
3817                         Prev := Homonym (Prev);
3818                      end loop;
3819
3820                      Set_Homonym (Prev, Lim_Typ);
3821                   end if;
3822                end;
3823
3824                if Debug_Flag_I then
3825                   Write_Str ("   (homonym) chain ");
3826                   Write_Name (Chars (Lim_Typ));
3827                   Write_Eol;
3828                end if;
3829             end if;
3830
3831             Next_Entity (Lim_Typ);
3832          end loop;
3833       end if;
3834
3835       --  The package must be visible while the limited-with clause is active
3836       --  because references to the type P.T must resolve in the usual way.
3837       --  In addition, we remember that the limited-view has been installed to
3838       --  uninstall it at the point of context removal.
3839
3840       Set_Is_Immediately_Visible (P);
3841       Set_Limited_View_Installed (N);
3842       Set_From_With_Type (P);
3843    end Install_Limited_Withed_Unit;
3844
3845    -------------------------
3846    -- Install_Withed_Unit --
3847    -------------------------
3848
3849    procedure Install_Withed_Unit
3850      (With_Clause     : Node_Id;
3851       Private_With_OK : Boolean := False)
3852    is
3853       Uname : constant Entity_Id := Entity (Name (With_Clause));
3854       P     : constant Entity_Id := Scope (Uname);
3855
3856    begin
3857       --  Ada 2005 (AI-262): Do not install the private withed unit if we are
3858       --  compiling a package declaration and the Private_With_OK flag was not
3859       --  set by the caller. These declarations will be installed later (before
3860       --  analyzing the private part of the package).
3861
3862       if Private_Present (With_Clause)
3863         and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration
3864         and then not (Private_With_OK)
3865       then
3866          return;
3867       end if;
3868
3869       if Debug_Flag_I then
3870          if Private_Present (With_Clause) then
3871             Write_Str ("install private withed unit ");
3872          else
3873             Write_Str ("install withed unit ");
3874          end if;
3875
3876          Write_Name (Chars (Uname));
3877          Write_Eol;
3878       end if;
3879
3880       --  We do not apply the restrictions to an internal unit unless
3881       --  we are compiling the internal unit as a main unit. This check
3882       --  is also skipped for dummy units (for missing packages).
3883
3884       if Sloc (Uname) /= No_Location
3885         and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
3886                     or else Current_Sem_Unit = Main_Unit)
3887       then
3888          Check_Restricted_Unit
3889            (Unit_Name (Get_Source_Unit (Uname)), With_Clause);
3890       end if;
3891
3892       if P /= Standard_Standard then
3893
3894          --  If the unit is not analyzed after analysis of the with clause and
3895          --  it is an instantiation then it awaits a body and is the main unit.
3896          --  Its appearance in the context of some other unit indicates a
3897          --  circular dependency (DEC suite perversity).
3898
3899          if not Analyzed (Uname)
3900            and then Nkind (Parent (Uname)) = N_Package_Instantiation
3901          then
3902             Error_Msg_N
3903               ("instantiation depends on itself", Name (With_Clause));
3904
3905          elsif not Is_Visible_Child_Unit (Uname) then
3906             Set_Is_Visible_Child_Unit (Uname);
3907
3908             --  If the child unit appears in the context of its parent, it is
3909             --  immediately visible.
3910
3911             if In_Open_Scopes (Scope (Uname)) then
3912                Set_Is_Immediately_Visible (Uname);
3913             end if;
3914
3915             if Is_Generic_Instance (Uname)
3916               and then Ekind (Uname) in Subprogram_Kind
3917             then
3918                --  Set flag as well on the visible entity that denotes the
3919                --  instance, which renames the current one.
3920
3921                Set_Is_Visible_Child_Unit
3922                  (Related_Instance
3923                    (Defining_Entity (Unit (Library_Unit (With_Clause)))));
3924             end if;
3925
3926             --  The parent unit may have been installed already, and may have
3927             --  appeared in a use clause.
3928
3929             if In_Use (Scope (Uname)) then
3930                Set_Is_Potentially_Use_Visible (Uname);
3931             end if;
3932
3933             Set_Context_Installed (With_Clause);
3934          end if;
3935
3936       elsif not Is_Immediately_Visible (Uname) then
3937          if not Private_Present (With_Clause)
3938            or else Private_With_OK
3939          then
3940             Set_Is_Immediately_Visible (Uname);
3941          end if;
3942
3943          Set_Context_Installed (With_Clause);
3944       end if;
3945
3946       --   A with-clause overrides a with-type clause: there are no restric-
3947       --   tions on the use of package entities.
3948
3949       if Ekind (Uname) = E_Package then
3950          Set_From_With_Type (Uname, False);
3951       end if;
3952
3953       --  Ada 2005 (AI-377): it is illegal for a with_clause to name a child
3954       --  unit if there is a visible homograph for it declared in the same
3955       --  declarative region. This pathological case can only arise when an
3956       --  instance I1 of a generic unit G1 has an explicit child unit I1.G2,
3957       --  G1 has a generic child also named G2, and the context includes with_
3958       --  clauses for both I1.G2 and for G1.G2, making an implicit declaration
3959       --  of I1.G2 visible as well. If the child unit is named Standard, do
3960       --  not apply the check to the Standard package itself.
3961
3962       if Is_Child_Unit (Uname)
3963         and then Is_Visible_Child_Unit (Uname)
3964         and then Ada_Version >= Ada_05
3965       then
3966          declare
3967             Decl1 : constant Node_Id  := Unit_Declaration_Node (P);
3968             Decl2 : Node_Id;
3969             P2    : Entity_Id;
3970             U2    : Entity_Id;
3971
3972          begin
3973             U2 := Homonym (Uname);
3974             while Present (U2)
3975               and U2 /= Standard_Standard
3976            loop
3977                P2 := Scope (U2);
3978                Decl2  := Unit_Declaration_Node (P2);
3979
3980                if Is_Child_Unit (U2)
3981                  and then Is_Visible_Child_Unit (U2)
3982                then
3983                   if Is_Generic_Instance (P)
3984                     and then Nkind (Decl1) = N_Package_Declaration
3985                     and then Generic_Parent (Specification (Decl1)) = P2
3986                   then
3987                      Error_Msg_N ("illegal with_clause", With_Clause);
3988                      Error_Msg_N
3989                        ("\child unit has visible homograph" &
3990                            " ('R'M 8.3(26), 10.1.1(19))",
3991                          With_Clause);
3992                      exit;
3993
3994                   elsif Is_Generic_Instance (P2)
3995                     and then Nkind (Decl2) = N_Package_Declaration
3996                     and then Generic_Parent (Specification (Decl2)) = P
3997                   then
3998                      --  With_clause for child unit of instance appears before
3999                      --  in the context. We want to place the error message on
4000                      --  it, not on the generic child unit itself.
4001
4002                      declare
4003                         Prev_Clause : Node_Id;
4004
4005                      begin
4006                         Prev_Clause := First (List_Containing (With_Clause));
4007                         while Entity (Name (Prev_Clause)) /= U2 loop
4008                            Next (Prev_Clause);
4009                         end loop;
4010
4011                         pragma Assert (Present (Prev_Clause));
4012                         Error_Msg_N ("illegal with_clause", Prev_Clause);
4013                         Error_Msg_N
4014                           ("\child unit has visible homograph" &
4015                               " ('R'M 8.3(26), 10.1.1(19))",
4016                             Prev_Clause);
4017                         exit;
4018                      end;
4019                   end if;
4020                end if;
4021
4022                U2 := Homonym (U2);
4023             end loop;
4024          end;
4025       end if;
4026    end Install_Withed_Unit;
4027
4028    -------------------
4029    -- Is_Child_Spec --
4030    -------------------
4031
4032    function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is
4033       K : constant Node_Kind := Nkind (Lib_Unit);
4034
4035    begin
4036       return (K in N_Generic_Declaration              or else
4037               K in N_Generic_Instantiation            or else
4038               K in N_Generic_Renaming_Declaration     or else
4039               K =  N_Package_Declaration              or else
4040               K =  N_Package_Renaming_Declaration     or else
4041               K =  N_Subprogram_Declaration           or else
4042               K =  N_Subprogram_Renaming_Declaration)
4043         and then Present (Parent_Spec (Lib_Unit));
4044    end Is_Child_Spec;
4045
4046    -----------------------
4047    -- Load_Needed_Body --
4048    -----------------------
4049
4050    --  N is a generic unit named in a with clause, or else it is
4051    --  a unit that contains a generic unit or an inlined function.
4052    --  In order to perform an instantiation, the body of the unit
4053    --  must be present. If the unit itself is generic, we assume
4054    --  that an instantiation follows, and  load and analyze the body
4055    --  unconditionally. This forces analysis of the spec as well.
4056
4057    --  If the unit is not generic, but contains a generic unit, it
4058    --  is loaded on demand, at the point of instantiation (see ch12).
4059
4060    procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
4061       Body_Name : Unit_Name_Type;
4062       Unum      : Unit_Number_Type;
4063
4064       Save_Style_Check : constant Boolean := Opt.Style_Check;
4065       --  The loading and analysis is done with style checks off
4066
4067    begin
4068       if not GNAT_Mode then
4069          Style_Check := False;
4070       end if;
4071
4072       Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N)));
4073       Unum :=
4074         Load_Unit
4075           (Load_Name  => Body_Name,
4076            Required   => False,
4077            Subunit    => False,
4078            Error_Node => N,
4079            Renamings  => True);
4080
4081       if Unum = No_Unit then
4082          OK := False;
4083
4084       else
4085          Compiler_State := Analyzing; -- reset after load
4086
4087          if not Fatal_Error (Unum) or else Try_Semantics then
4088             if Debug_Flag_L then
4089                Write_Str ("*** Loaded generic body");
4090                Write_Eol;
4091             end if;
4092
4093             Semantics (Cunit (Unum));
4094          end if;
4095
4096          OK := True;
4097       end if;
4098
4099       Style_Check := Save_Style_Check;
4100    end Load_Needed_Body;
4101
4102    -------------------------
4103    -- Build_Limited_Views --
4104    -------------------------
4105
4106    procedure Build_Limited_Views (N : Node_Id) is
4107       Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
4108       P    : constant Entity_Id        := Cunit_Entity (Unum);
4109
4110       Spec        : Node_Id;            --  To denote a package specification
4111       Lim_Typ     : Entity_Id;          --  To denote shadow entities
4112       Comp_Typ    : Entity_Id;          --  To denote real entities
4113
4114       Lim_Header  : Entity_Id;          --  Package entity
4115       Last_Lim_E  : Entity_Id := Empty; --  Last limited entity built
4116       Last_Pub_Lim_E : Entity_Id;       --  To set the first private entity
4117
4118       procedure Decorate_Incomplete_Type
4119         (E    : Entity_Id;
4120          Scop : Entity_Id);
4121       --  Add attributes of an incomplete type to a shadow entity. The same
4122       --  attributes are placed on the real entity, so that gigi receives
4123       --  a consistent view.
4124
4125       procedure Decorate_Package_Specification (P : Entity_Id);
4126       --  Add attributes of a package entity to the entity in a package
4127       --  declaration
4128
4129       procedure Decorate_Tagged_Type
4130         (Loc  : Source_Ptr;
4131          T    : Entity_Id;
4132          Scop : Entity_Id);
4133       --  Set basic attributes of tagged type T, including its class_wide type.
4134       --  The parameters Loc, Scope are used to decorate the class_wide type.
4135
4136       procedure Build_Chain
4137         (Scope      : Entity_Id;
4138          First_Decl : Node_Id);
4139       --  Construct list of shadow entities and attach it to entity of
4140       --  package that is mentioned in a limited_with clause.
4141
4142       function New_Internal_Shadow_Entity
4143         (Kind       : Entity_Kind;
4144          Sloc_Value : Source_Ptr;
4145          Id_Char    : Character) return Entity_Id;
4146       --  Build a new internal entity and append it to the list of shadow
4147       --  entities available through the limited-header
4148
4149       ------------------------------
4150       -- Decorate_Incomplete_Type --
4151       ------------------------------
4152
4153       procedure Decorate_Incomplete_Type
4154         (E    : Entity_Id;
4155          Scop : Entity_Id)
4156       is
4157       begin
4158          Set_Ekind             (E, E_Incomplete_Type);
4159          Set_Scope             (E, Scop);
4160          Set_Etype             (E, E);
4161          Set_Is_First_Subtype  (E, True);
4162          Set_Stored_Constraint (E, No_Elist);
4163          Set_Full_View         (E, Empty);
4164          Init_Size_Align       (E);
4165       end Decorate_Incomplete_Type;
4166
4167       --------------------------
4168       -- Decorate_Tagged_Type --
4169       --------------------------
4170
4171       procedure Decorate_Tagged_Type
4172         (Loc  : Source_Ptr;
4173          T    : Entity_Id;
4174          Scop : Entity_Id)
4175       is
4176          CW : Entity_Id;
4177
4178       begin
4179          Decorate_Incomplete_Type (T, Scop);
4180          Set_Is_Tagged_Type (T);
4181
4182          --  Build corresponding class_wide type, if not previously done
4183
4184          if No (Class_Wide_Type (T)) then
4185             CW := Make_Defining_Identifier (Loc,  New_Internal_Name ('S'));
4186
4187             Set_Ekind                     (CW, E_Class_Wide_Type);
4188             Set_Etype                     (CW, T);
4189             Set_Scope                     (CW, Scop);
4190             Set_Is_Tagged_Type            (CW);
4191             Set_Is_First_Subtype          (CW, True);
4192             Init_Size_Align               (CW);
4193             Set_Has_Unknown_Discriminants (CW, True);
4194             Set_Class_Wide_Type           (CW, CW);
4195             Set_Equivalent_Type           (CW, Empty);
4196             Set_From_With_Type            (CW, From_With_Type (T));
4197
4198             Set_Class_Wide_Type           (T, CW);
4199          end if;
4200       end Decorate_Tagged_Type;
4201
4202       ------------------------------------
4203       -- Decorate_Package_Specification --
4204       ------------------------------------
4205
4206       procedure Decorate_Package_Specification (P : Entity_Id) is
4207       begin
4208          --  Place only the most basic attributes
4209
4210          Set_Ekind (P, E_Package);
4211          Set_Etype (P, Standard_Void_Type);
4212       end Decorate_Package_Specification;
4213
4214       -------------------------
4215       -- New_Internal_Entity --
4216       -------------------------
4217
4218       function New_Internal_Shadow_Entity
4219         (Kind       : Entity_Kind;
4220          Sloc_Value : Source_Ptr;
4221          Id_Char    : Character) return Entity_Id
4222       is
4223          E : constant Entity_Id :=
4224                Make_Defining_Identifier (Sloc_Value,
4225                  Chars => New_Internal_Name (Id_Char));
4226
4227       begin
4228          Set_Ekind       (E, Kind);
4229          Set_Is_Internal (E, True);
4230
4231          if Kind in Type_Kind then
4232             Init_Size_Align (E);
4233          end if;
4234
4235          Append_Entity (E, Lim_Header);
4236          Last_Lim_E := E;
4237          return E;
4238       end New_Internal_Shadow_Entity;
4239
4240       -----------------
4241       -- Build_Chain --
4242       -----------------
4243
4244       procedure Build_Chain
4245         (Scope         : Entity_Id;
4246          First_Decl    : Node_Id)
4247       is
4248          Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
4249          Is_Tagged     : Boolean;
4250          Decl          : Node_Id;
4251
4252       begin
4253          Decl := First_Decl;
4254          while Present (Decl) loop
4255
4256             --  For each library_package_declaration in the environment, there
4257             --  is an implicit declaration of a *limited view* of that library
4258             --  package. The limited view of a package contains:
4259             --
4260             --   * For each nested package_declaration, a declaration of the
4261             --     limited view of that package, with the same defining-
4262             --     program-unit name.
4263             --
4264             --   * For each type_declaration in the visible part, an incomplete
4265             --     type-declaration with the same defining_identifier, whose
4266             --     completion is the type_declaration. If the type_declaration
4267             --     is tagged, then the incomplete_type_declaration is tagged
4268             --     incomplete.
4269
4270             if Nkind (Decl) = N_Full_Type_Declaration then
4271                Is_Tagged :=
4272                   Nkind (Type_Definition (Decl)) = N_Record_Definition
4273                     and then Tagged_Present (Type_Definition (Decl));
4274
4275                Comp_Typ := Defining_Identifier (Decl);
4276
4277                if not Analyzed_Unit then
4278                   if Is_Tagged then
4279                      Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
4280                   else
4281                      Decorate_Incomplete_Type (Comp_Typ, Scope);
4282                   end if;
4283                end if;
4284
4285                --  Create shadow entity for type
4286
4287                Lim_Typ := New_Internal_Shadow_Entity
4288                  (Kind       => Ekind (Comp_Typ),
4289                   Sloc_Value => Sloc (Comp_Typ),
4290                   Id_Char    => 'Z');
4291
4292                Set_Chars  (Lim_Typ, Chars (Comp_Typ));
4293                Set_Parent (Lim_Typ, Parent (Comp_Typ));
4294                Set_From_With_Type (Lim_Typ);
4295
4296                if Is_Tagged then
4297                   Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
4298                else
4299                   Decorate_Incomplete_Type (Lim_Typ, Scope);
4300                end if;
4301
4302                Set_Non_Limited_View (Lim_Typ, Comp_Typ);
4303
4304             elsif Nkind (Decl) = N_Private_Type_Declaration then
4305                Comp_Typ := Defining_Identifier (Decl);
4306
4307                if not Analyzed_Unit then
4308                   if Tagged_Present (Decl) then
4309                      Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
4310                   else
4311                      Decorate_Incomplete_Type (Comp_Typ, Scope);
4312                   end if;
4313                end if;
4314
4315                Lim_Typ  := New_Internal_Shadow_Entity
4316                  (Kind       => Ekind (Comp_Typ),
4317                   Sloc_Value => Sloc (Comp_Typ),
4318                   Id_Char    => 'Z');
4319
4320                Set_Chars  (Lim_Typ, Chars (Comp_Typ));
4321                Set_Parent (Lim_Typ, Parent (Comp_Typ));
4322                Set_From_With_Type (Lim_Typ);
4323
4324                if Tagged_Present (Decl) then
4325                   Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
4326                else
4327                   Decorate_Incomplete_Type (Lim_Typ, Scope);
4328                end if;
4329
4330                Set_Non_Limited_View (Lim_Typ, Comp_Typ);
4331
4332             elsif Nkind (Decl) = N_Private_Extension_Declaration then
4333                Comp_Typ := Defining_Identifier (Decl);
4334
4335                if not Analyzed_Unit then
4336                   Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
4337                end if;
4338
4339                --  Create shadow entity for type
4340
4341                Lim_Typ := New_Internal_Shadow_Entity
4342                  (Kind       => Ekind (Comp_Typ),
4343                   Sloc_Value => Sloc (Comp_Typ),
4344                   Id_Char    => 'Z');
4345
4346                Set_Chars  (Lim_Typ, Chars (Comp_Typ));
4347                Set_Parent (Lim_Typ, Parent (Comp_Typ));
4348                Set_From_With_Type (Lim_Typ);
4349
4350                Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
4351                Set_Non_Limited_View (Lim_Typ, Comp_Typ);
4352
4353             elsif Nkind (Decl) = N_Package_Declaration then
4354
4355                --  Local package
4356
4357                declare
4358                   Spec : constant Node_Id := Specification (Decl);
4359
4360                begin
4361                   Comp_Typ := Defining_Unit_Name (Spec);
4362
4363                   if not Analyzed (Cunit (Unum)) then
4364                      Decorate_Package_Specification (Comp_Typ);
4365                      Set_Scope (Comp_Typ, Scope);
4366                   end if;
4367
4368                   Lim_Typ  := New_Internal_Shadow_Entity
4369                     (Kind       => Ekind (Comp_Typ),
4370                      Sloc_Value => Sloc (Comp_Typ),
4371                      Id_Char    => 'Z');
4372
4373                   Decorate_Package_Specification (Lim_Typ);
4374                   Set_Scope (Lim_Typ, Scope);
4375
4376                   Set_Chars (Lim_Typ, Chars (Comp_Typ));
4377                   Set_Parent (Lim_Typ, Parent (Comp_Typ));
4378                   Set_From_With_Type (Lim_Typ);
4379
4380                   --  Note: The non_limited_view attribute is not used
4381                   --  for local packages.
4382
4383                   Build_Chain
4384                     (Scope      => Lim_Typ,
4385                      First_Decl => First (Visible_Declarations (Spec)));
4386                end;
4387             end if;
4388
4389             Next (Decl);
4390          end loop;
4391       end Build_Chain;
4392
4393    --  Start of processing for Build_Limited_Views
4394
4395    begin
4396       pragma Assert (Limited_Present (N));
4397
4398       --  A library_item mentioned in a limited_with_clause shall be
4399       --  a package_declaration, not a subprogram_declaration,
4400       --  generic_declaration, generic_instantiation, or
4401       --  package_renaming_declaration
4402
4403       case Nkind (Unit (Library_Unit (N))) is
4404
4405          when N_Package_Declaration =>
4406             null;
4407
4408          when N_Subprogram_Declaration =>
4409             Error_Msg_N ("subprograms not allowed in "
4410                          & "limited with_clauses", N);
4411             return;
4412
4413          when N_Generic_Package_Declaration |
4414               N_Generic_Subprogram_Declaration =>
4415             Error_Msg_N ("generics not allowed in "
4416                          & "limited with_clauses", N);
4417             return;
4418
4419          when N_Generic_Instantiation =>
4420             Error_Msg_N ("generic instantiations not allowed in "
4421                          & "limited with_clauses", N);
4422             return;
4423
4424          when N_Generic_Renaming_Declaration =>
4425             Error_Msg_N ("generic renamings not allowed in "
4426                          & "limited with_clauses", N);
4427             return;
4428
4429          when N_Subprogram_Renaming_Declaration =>
4430             Error_Msg_N ("renamed subprograms not allowed in "
4431                          & "limited with_clauses", N);
4432             return;
4433
4434          when N_Package_Renaming_Declaration =>
4435             Error_Msg_N ("renamed packages not allowed in "
4436                          & "limited with_clauses", N);
4437             return;
4438
4439          when others =>
4440             raise Program_Error;
4441       end case;
4442
4443       --  Check if the chain is already built
4444
4445       Spec := Specification (Unit (Library_Unit (N)));
4446
4447       if Limited_View_Installed (Spec) then
4448          return;
4449       end if;
4450
4451       Set_Ekind (P, E_Package);
4452
4453       --  Build the header of the limited_view
4454
4455       Lim_Header := Make_Defining_Identifier (Sloc (N),
4456                       Chars => New_Internal_Name (Id_Char => 'Z'));
4457       Set_Ekind (Lim_Header, E_Package);
4458       Set_Is_Internal (Lim_Header);
4459       Set_Limited_View (P, Lim_Header);
4460
4461       --  Create the auxiliary chain. All the shadow entities are appended
4462       --  to the list of entities of the limited-view header
4463
4464       Build_Chain
4465         (Scope      => P,
4466          First_Decl => First (Visible_Declarations (Spec)));
4467
4468       --  Save the last built shadow entity. It is needed later to set the
4469       --  reference to the first shadow entity in the private part
4470
4471       Last_Pub_Lim_E := Last_Lim_E;
4472
4473       --  Ada 2005 (AI-262): Add the limited view of the private declarations
4474       --  Required to give support to limited-private-with clauses
4475
4476       Build_Chain (Scope      => P,
4477                    First_Decl => First (Private_Declarations (Spec)));
4478
4479       if Last_Pub_Lim_E /= Empty then
4480          Set_First_Private_Entity (Lim_Header,
4481                                    Next_Entity (Last_Pub_Lim_E));
4482       else
4483          Set_First_Private_Entity (Lim_Header,
4484                                    First_Entity (P));
4485       end if;
4486
4487       Set_Limited_View_Installed (Spec);
4488    end Build_Limited_Views;
4489
4490    -------------------------------
4491    -- Check_Body_Needed_For_SAL --
4492    -------------------------------
4493
4494    procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
4495
4496       function Entity_Needs_Body (E : Entity_Id) return Boolean;
4497       --  Determine whether use of entity E might require the presence
4498       --  of its body. For a package this requires a recursive traversal
4499       --  of all nested declarations.
4500
4501       ---------------------------
4502       -- Entity_Needed_For_SAL --
4503       ---------------------------
4504
4505       function Entity_Needs_Body (E : Entity_Id) return Boolean is
4506          Ent : Entity_Id;
4507
4508       begin
4509          if Is_Subprogram (E)
4510            and then Has_Pragma_Inline (E)
4511          then
4512             return True;
4513
4514          elsif Ekind (E) = E_Generic_Function
4515            or else Ekind (E) = E_Generic_Procedure
4516          then
4517             return True;
4518
4519          elsif Ekind (E) = E_Generic_Package
4520            and then
4521              Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration
4522            and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
4523          then
4524             return True;
4525
4526          elsif Ekind (E) = E_Package
4527            and then
4528              Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
4529            and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
4530          then
4531             Ent := First_Entity (E);
4532             while Present (Ent) loop
4533                if Entity_Needs_Body (Ent) then
4534                   return True;
4535                end if;
4536
4537                Next_Entity (Ent);
4538             end loop;
4539
4540             return False;
4541
4542          else
4543             return False;
4544          end if;
4545       end Entity_Needs_Body;
4546
4547    --  Start of processing for Check_Body_Needed_For_SAL
4548
4549    begin
4550       if Ekind (Unit_Name) = E_Generic_Package
4551         and then
4552           Nkind (Unit_Declaration_Node (Unit_Name)) =
4553                                             N_Generic_Package_Declaration
4554         and then
4555           Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name)))
4556       then
4557          Set_Body_Needed_For_SAL (Unit_Name);
4558
4559       elsif Ekind (Unit_Name) = E_Generic_Procedure
4560         or else Ekind (Unit_Name) = E_Generic_Function
4561       then
4562          Set_Body_Needed_For_SAL (Unit_Name);
4563
4564       elsif Is_Subprogram (Unit_Name)
4565         and then Nkind (Unit_Declaration_Node (Unit_Name)) =
4566                                             N_Subprogram_Declaration
4567         and then Has_Pragma_Inline (Unit_Name)
4568       then
4569          Set_Body_Needed_For_SAL (Unit_Name);
4570
4571       elsif Ekind (Unit_Name) = E_Subprogram_Body then
4572          Check_Body_Needed_For_SAL
4573            (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
4574
4575       elsif Ekind (Unit_Name) = E_Package
4576         and then Entity_Needs_Body (Unit_Name)
4577       then
4578          Set_Body_Needed_For_SAL (Unit_Name);
4579
4580       elsif Ekind (Unit_Name) = E_Package_Body
4581         and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body
4582       then
4583          Check_Body_Needed_For_SAL
4584            (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
4585       end if;
4586    end Check_Body_Needed_For_SAL;
4587
4588    --------------------
4589    -- Remove_Context --
4590    --------------------
4591
4592    procedure Remove_Context (N : Node_Id) is
4593       Lib_Unit : constant Node_Id := Unit (N);
4594
4595    begin
4596       --  If this is a child unit, first remove the parent units
4597
4598       if Is_Child_Spec (Lib_Unit) then
4599          Remove_Parents (Lib_Unit);
4600       end if;
4601
4602       Remove_Context_Clauses (N);
4603    end Remove_Context;
4604
4605    ----------------------------
4606    -- Remove_Context_Clauses --
4607    ----------------------------
4608
4609    procedure Remove_Context_Clauses (N : Node_Id) is
4610       Item      : Node_Id;
4611       Unit_Name : Entity_Id;
4612
4613    begin
4614       --  Ada 2005 (AI-50217): We remove the context clauses in two phases:
4615       --  limited-views first and regular-views later (to maintain the
4616       --  stack model).
4617
4618       --  First Phase: Remove limited_with context clauses
4619
4620       Item := First (Context_Items (N));
4621       while Present (Item) loop
4622
4623          --  We are interested only in with clauses which got installed
4624          --  on entry.
4625
4626          if Nkind (Item) = N_With_Clause
4627            and then Limited_Present (Item)
4628            and then Limited_View_Installed (Item)
4629          then
4630             Remove_Limited_With_Clause (Item);
4631          end if;
4632
4633          Next (Item);
4634       end loop;
4635
4636       --  Second Phase: Loop through context items and undo regular
4637       --  with_clauses and use_clauses.
4638
4639       Item := First (Context_Items (N));
4640       while Present (Item) loop
4641
4642          --  We are interested only in with clauses which got installed
4643          --  on entry, as indicated by their Context_Installed flag set
4644
4645          if Nkind (Item) = N_With_Clause
4646            and then Limited_Present (Item)
4647            and then Limited_View_Installed (Item)
4648          then
4649             null;
4650
4651          elsif Nkind (Item) = N_With_Clause
4652             and then Context_Installed (Item)
4653          then
4654             --  Remove items from one with'ed unit
4655
4656             Unit_Name := Entity (Name (Item));
4657             Remove_Unit_From_Visibility (Unit_Name);
4658             Set_Context_Installed (Item, False);
4659
4660          elsif Nkind (Item) = N_Use_Package_Clause then
4661             End_Use_Package (Item);
4662
4663          elsif Nkind (Item) = N_Use_Type_Clause then
4664             End_Use_Type (Item);
4665
4666          elsif Nkind (Item) = N_With_Type_Clause then
4667             Remove_With_Type_Clause (Name (Item));
4668          end if;
4669
4670          Next (Item);
4671       end loop;
4672    end Remove_Context_Clauses;
4673
4674    --------------------------------
4675    -- Remove_Limited_With_Clause --
4676    --------------------------------
4677
4678    procedure Remove_Limited_With_Clause (N : Node_Id) is
4679       P_Unit     : constant Entity_Id := Unit (Library_Unit (N));
4680       P          : Entity_Id;
4681       Lim_Header : Entity_Id;
4682       Lim_Typ    : Entity_Id;
4683       Prev       : Entity_Id;
4684
4685    begin
4686       pragma Assert (Limited_View_Installed (N));
4687
4688       --  In case of limited with_clause on subprograms, generics, instances,
4689       --  or renamings, the corresponding error was previously posted and we
4690       --  have nothing to do here.
4691
4692       if Nkind (P_Unit) /= N_Package_Declaration then
4693          return;
4694       end if;
4695
4696       P := Defining_Unit_Name (Specification (P_Unit));
4697
4698       --  Handle child packages
4699
4700       if Nkind (P) = N_Defining_Program_Unit_Name then
4701          P := Defining_Identifier (P);
4702       end if;
4703
4704       if Debug_Flag_I then
4705          Write_Str ("remove limited view of ");
4706          Write_Name (Chars (P));
4707          Write_Str (" from visibility");
4708          Write_Eol;
4709       end if;
4710
4711       --  Prepare the removal of the shadow entities from visibility. The
4712       --  first element of the limited view is a header (an E_Package
4713       --  entity) that is used to reference the first shadow entity in the
4714       --  private part of the package
4715
4716       Lim_Header := Limited_View (P);
4717       Lim_Typ    := First_Entity (Lim_Header);
4718
4719       --  Remove package and shadow entities from visibility if it has not
4720       --  been analyzed
4721
4722       if not Analyzed (P_Unit) then
4723          Unchain (P);
4724          Set_Is_Immediately_Visible (P, False);
4725
4726          while Present (Lim_Typ) loop
4727             Unchain (Lim_Typ);
4728             Next_Entity (Lim_Typ);
4729          end loop;
4730
4731       --  Otherwise this package has already appeared in the closure and its
4732       --  shadow entities must be replaced by its real entities. This code
4733       --  must be kept synchronized with the complementary code in Install
4734       --  Limited_Withed_Unit.
4735
4736       else
4737          --  Real entities that are type or subtype declarations were hidden
4738          --  from visibility at the point of installation of the limited-view.
4739          --  Now we recover the previous value of the hidden attribute.
4740
4741          declare
4742             E : Entity_Id;
4743
4744          begin
4745             E := First_Entity (P);
4746             while Present (E) and then E /= First_Private_Entity (P) loop
4747                if Is_Type (E) then
4748                   Set_Is_Hidden (E, Was_Hidden (E));
4749                end if;
4750
4751                Next_Entity (E);
4752             end loop;
4753          end;
4754
4755          while Present (Lim_Typ)
4756            and then Lim_Typ /= First_Private_Entity (Lim_Header)
4757          loop
4758             pragma Assert (not In_Chain (Non_Limited_View (Lim_Typ)));
4759
4760             --  Child units have not been unchained
4761
4762             if not Is_Child_Unit (Non_Limited_View (Lim_Typ)) then
4763                Prev := Current_Entity (Lim_Typ);
4764
4765                if Prev = Lim_Typ then
4766                   Set_Current_Entity (Non_Limited_View (Lim_Typ));
4767                else
4768                   while Present (Prev)
4769                     and then Homonym (Prev) /= Lim_Typ
4770                   loop
4771                      Prev := Homonym (Prev);
4772                   end loop;
4773
4774                   pragma Assert (Present (Prev));
4775                   Set_Homonym (Prev, Non_Limited_View (Lim_Typ));
4776                end if;
4777
4778                --  We must also set the next homonym entity of the real entity
4779                --  to handle the case in which the next homonym was a shadow
4780                --  entity.
4781
4782                Set_Homonym (Non_Limited_View (Lim_Typ), Homonym (Lim_Typ));
4783             end if;
4784
4785             Next_Entity (Lim_Typ);
4786          end loop;
4787       end if;
4788
4789       --  Indicate that the limited view of the package is not installed
4790
4791       Set_From_With_Type         (P, False);
4792       Set_Limited_View_Installed (N, False);
4793    end Remove_Limited_With_Clause;
4794
4795    --------------------
4796    -- Remove_Parents --
4797    --------------------
4798
4799    procedure Remove_Parents (Lib_Unit : Node_Id) is
4800       P      : Node_Id;
4801       P_Name : Entity_Id;
4802       P_Spec : Node_Id := Empty;
4803       E      : Entity_Id;
4804       Vis    : constant Boolean :=
4805                  Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
4806
4807    begin
4808       if Is_Child_Spec (Lib_Unit) then
4809          P_Spec := Parent_Spec (Lib_Unit);
4810
4811       elsif Nkind (Lib_Unit) = N_Package_Body
4812         and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation
4813       then
4814          P_Spec := Parent_Spec (Original_Node (Lib_Unit));
4815       end if;
4816
4817       if Present (P_Spec) then
4818
4819          P := Unit (P_Spec);
4820          P_Name := Get_Parent_Entity (P);
4821          Remove_Context_Clauses (P_Spec);
4822          End_Package_Scope (P_Name);
4823          Set_Is_Immediately_Visible (P_Name, Vis);
4824
4825          --  Remove from visibility the siblings as well, which are directly
4826          --  visible while the parent is in scope.
4827
4828          E := First_Entity (P_Name);
4829          while Present (E) loop
4830             if Is_Child_Unit (E) then
4831                Set_Is_Immediately_Visible (E, False);
4832             end if;
4833
4834             Next_Entity (E);
4835          end loop;
4836
4837          Set_In_Package_Body (P_Name, False);
4838
4839          --  This is the recursive call to remove the context of any
4840          --  higher level parent. This recursion ensures that all parents
4841          --  are removed in the reverse order of their installation.
4842
4843          Remove_Parents (P);
4844       end if;
4845    end Remove_Parents;
4846
4847    -----------------------------
4848    -- Remove_With_Type_Clause --
4849    -----------------------------
4850
4851    procedure Remove_With_Type_Clause (Name : Node_Id) is
4852       Typ : Entity_Id;
4853       P   : Entity_Id;
4854
4855       procedure Unchain (E : Entity_Id);
4856       --  Remove entity from visibility list
4857
4858       -------------
4859       -- Unchain --
4860       -------------
4861
4862       procedure Unchain (E : Entity_Id) is
4863          Prev : Entity_Id;
4864
4865       begin
4866          Prev := Current_Entity (E);
4867
4868          --  Package entity may appear is several with_type_clauses, and
4869          --  may have been removed already.
4870
4871          if No (Prev) then
4872             return;
4873
4874          elsif Prev = E then
4875             Set_Name_Entity_Id (Chars (E), Homonym (E));
4876
4877          else
4878             while Present (Prev)
4879               and then Homonym (Prev) /= E
4880             loop
4881                Prev := Homonym (Prev);
4882             end loop;
4883
4884             if Present (Prev) then
4885                Set_Homonym (Prev, Homonym (E));
4886             end if;
4887          end if;
4888       end Unchain;
4889
4890    --  Start of processing for Remove_With_Type_Clause
4891
4892    begin
4893       if Nkind (Name) = N_Selected_Component then
4894          Typ := Entity (Selector_Name (Name));
4895
4896          --  If no Typ, then error in declaration, ignore
4897
4898          if No (Typ) then
4899             return;
4900          end if;
4901       else
4902          return;
4903       end if;
4904
4905       P := Scope (Typ);
4906
4907       --  If the exporting package has been analyzed, it has appeared in the
4908       --  context already and should be left alone. Otherwise, remove from
4909       --  visibility.
4910
4911       if not Analyzed (Unit_Declaration_Node (P)) then
4912          Unchain (P);
4913          Unchain (Typ);
4914          Set_Is_Frozen (Typ, False);
4915       end if;
4916
4917       if Ekind (Typ) = E_Record_Type then
4918          Set_From_With_Type (Class_Wide_Type (Typ), False);
4919          Set_From_With_Type (Typ, False);
4920       end if;
4921
4922       Set_From_With_Type (P, False);
4923
4924       --  If P is a child unit, remove parents as well
4925
4926       P := Scope (P);
4927       while Present (P)
4928         and then P /= Standard_Standard
4929       loop
4930          Set_From_With_Type (P, False);
4931
4932          if not Analyzed (Unit_Declaration_Node (P)) then
4933             Unchain (P);
4934          end if;
4935
4936          P := Scope (P);
4937       end loop;
4938
4939       --  The back-end needs to know that an access type is imported, so it
4940       --  does not need elaboration and can appear in a mutually recursive
4941       --  record definition, so the imported flag on an access  type is
4942       --  preserved.
4943
4944    end Remove_With_Type_Clause;
4945
4946    ---------------------------------
4947    -- Remove_Unit_From_Visibility --
4948    ---------------------------------
4949
4950    procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
4951       P : constant Entity_Id := Scope (Unit_Name);
4952
4953    begin
4954
4955       if Debug_Flag_I then
4956          Write_Str ("remove unit ");
4957          Write_Name (Chars (Unit_Name));
4958          Write_Str (" from visibility");
4959          Write_Eol;
4960       end if;
4961
4962       if P /= Standard_Standard then
4963          Set_Is_Visible_Child_Unit (Unit_Name, False);
4964       end if;
4965
4966       Set_Is_Potentially_Use_Visible (Unit_Name, False);
4967       Set_Is_Immediately_Visible     (Unit_Name, False);
4968
4969    end Remove_Unit_From_Visibility;
4970
4971    -------------
4972    -- Unchain --
4973    -------------
4974
4975    procedure Unchain (E : Entity_Id) is
4976       Prev : Entity_Id;
4977
4978    begin
4979       Prev := Current_Entity (E);
4980
4981       if No (Prev) then
4982          return;
4983
4984       elsif Prev = E then
4985          Set_Name_Entity_Id (Chars (E), Homonym (E));
4986
4987       else
4988          while Present (Prev)
4989            and then Homonym (Prev) /= E
4990          loop
4991             Prev := Homonym (Prev);
4992          end loop;
4993
4994          if Present (Prev) then
4995             Set_Homonym (Prev, Homonym (E));
4996          end if;
4997       end if;
4998
4999       if Debug_Flag_I then
5000          Write_Str ("   (homonym) unchain ");
5001          Write_Name (Chars (E));
5002          Write_Eol;
5003       end if;
5004
5005    end Unchain;
5006 end Sem_Ch10;