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