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