gcc/ada/sem_ch10.adb

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