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 --                            $Revision: 1.2 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Atree;    use Atree;
  30 with Debug;    use Debug;
  31 with Einfo;    use Einfo;
  32 with Errout;   use Errout;
  33 with Exp_Util; use Exp_Util;
  34 with Fname;    use Fname;
  35 with Fname.UF; use Fname.UF;
  36 with Freeze;   use Freeze;
  37 with Impunit;  use Impunit;
  38 with Inline;   use Inline;
  39 with Lib;      use Lib;
  40 with Lib.Load; use Lib.Load;
  41 with Lib.Xref; use Lib.Xref;
  42 with Namet;    use Namet;
  43 with Nlists;   use Nlists;
  44 with Nmake;    use Nmake;
  45 with Opt;      use Opt;
  46 with Output;   use Output;
  47 with Restrict; use Restrict;
  48 with Sem;      use Sem;
  49 with Sem_Ch6;  use Sem_Ch6;
  50 with Sem_Ch7;  use Sem_Ch7;
  51 with Sem_Ch8;  use Sem_Ch8;
  52 with Sem_Dist; use Sem_Dist;
  53 with Sem_Prag; use Sem_Prag;
  54 with Sem_Util; use Sem_Util;
  55 with Sem_Warn; use Sem_Warn;
  56 with Stand;    use Stand;
  57 with Sinfo;    use Sinfo;
  58 with Sinfo.CN; use Sinfo.CN;
  59 with Sinput;   use Sinput;
  60 with Snames;   use Snames;
  61 with Style;    use Style;
  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 Check_With_Type_Clauses (N : Node_Id);
  76    --  If N is a body, verify that any with_type clauses on the spec, or
  77    --  on the spec of any parent, have a matching with_clause.
  78
  79    procedure Check_Private_Child_Unit (N : Node_Id);
  80    --  If a with_clause mentions a private child unit, the compilation
  81    --  unit must be a member of the same family, as described in 10.1.2 (8).
  82
  83    procedure Check_Stub_Level (N : Node_Id);
  84    --  Verify that a stub is declared immediately within a compilation unit,
  85    --  and not in an inner frame.
  86
  87    procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
  88    --  When a child unit appears in a context clause, the implicit withs on
  89    --  parents are made explicit, and with clauses are inserted in the context
  90    --  clause before the one for the child. If a parent in the with_clause
  91    --  is a renaming, the implicit with_clause is on the renaming whose name
  92    --  is mentioned in the with_clause, and not on the package it renames.
  93    --  N is the compilation unit whose list of context items receives the
  94    --  implicit with_clauses.
  95
  96    procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
  97    --  If the main unit is a child unit, implicit withs are also added for
  98    --  all its ancestors.
  99
 100    procedure Install_Context_Clauses (N : Node_Id);
 101    --  Subsidiary to previous one. Process only with_ and use_clauses for
 102    --  current unit and its library unit if any.
 103
 104    procedure Install_Withed_Unit (With_Clause : Node_Id);
 105    --  If the unit is not a child unit, make unit immediately visible.
 106    --  The caller ensures that the unit is not already currently installed.
 107
 108    procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
 109    --  This procedure establishes the context for the compilation of a child
 110    --  unit. If Lib_Unit is a child library spec then the context of the parent
 111    --  is installed, and the parent itself made immediately visible, so that
 112    --  the child unit is processed in the declarative region of the parent.
 113    --  Install_Parents makes a recursive call to itself to ensure that all
 114    --  parents are loaded in the nested case. If Lib_Unit is a library body,
 115    --  the only effect of Install_Parents is to install the private decls of
 116    --  the parents, because the visible parent declarations will have been
 117    --  installed as part of the context of the corresponding spec.
 118
 119    procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id);
 120    --  In the compilation of a child unit, a child of any of the  ancestor
 121    --  units is directly visible if it is visible, because the parent is in
 122    --  an enclosing scope. Iterate over context to find child units of U_Name
 123    --  or of some ancestor of it.
 124
 125    function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
 126    --  Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
 127    --  returns True if Lib_Unit is a library spec which is a child spec, i.e.
 128    --  a library spec that has a parent. If the call to Is_Child_Spec returns
 129    --  True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
 130    --  compilation unit for the parent spec.
 131    --
 132    --  Lib_Unit can also be a subprogram body that acts as its own spec. If
 133    --  the Parent_Spec is  non-empty, this is also a child unit.
 134
 135    procedure Remove_With_Type_Clause (Name : Node_Id);
 136    --  Remove imported type and its enclosing package from visibility, and
 137    --  remove attributes of imported type so they don't interfere with its
 138    --  analysis (should it appear otherwise in the context).
 139
 140    procedure Remove_Context_Clauses (N : Node_Id);
 141    --  Subsidiary of previous one. Remove use_ and with_clauses.
 142
 143    procedure Remove_Parents (Lib_Unit : Node_Id);
 144    --  Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
 145    --  contexts established by the corresponding call to Install_Parents are
 146    --  removed. Remove_Parents contains a recursive call to itself to ensure
 147    --  that all parents are removed in the nested case.
 148
 149    procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
 150    --  Reset all visibility flags on unit after compiling it, either as a
 151    --  main unit or as a unit in the context.
 152
 153    procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
 154    --  Common processing for all stubs (subprograms, tasks, packages, and
 155    --  protected cases). N is the stub to be analyzed. Once the subunit
 156    --  name is established, load and analyze. Nam is the non-overloadable
 157    --  entity for which the proper body provides a completion. Subprogram
 158    --  stubs are handled differently because they can be declarations.
 159
 160    ------------------------------
 161    -- Analyze_Compilation_Unit --
 162    ------------------------------
 163
 164    procedure Analyze_Compilation_Unit (N : Node_Id) is
 165       Unit_Node     : constant Node_Id := Unit (N);
 166       Lib_Unit      : Node_Id          := Library_Unit (N);
 167       Spec_Id       : Node_Id;
 168       Main_Cunit    : constant Node_Id := Cunit (Main_Unit);
 169       Par_Spec_Name : Unit_Name_Type;
 170       Unum          : Unit_Number_Type;
 171
 172       procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
 173       --  Generate cross-reference information for the parents of child units.
 174       --  N is a defining_program_unit_name, and P_Id is the immediate parent.
 175
 176       --------------------------------
 177       -- Generate_Parent_References --
 178       --------------------------------
 179
 180       procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
 181          Pref   : Node_Id;
 182          P_Name : Entity_Id := P_Id;
 183
 184       begin
 185          Pref   := Name (Parent (Defining_Entity (N)));
 186
 187          if Nkind (Pref) = N_Expanded_Name then
 188
 189             --  Done already, if the unit has been compiled indirectly as
 190             --  part of the closure of its context because of inlining.
 191
 192             return;
 193          end if;
 194
 195          while Nkind (Pref) = N_Selected_Component loop
 196             Change_Selected_Component_To_Expanded_Name (Pref);
 197             Set_Entity (Pref, P_Name);
 198             Set_Etype (Pref, Etype (P_Name));
 199             Generate_Reference (P_Name, Pref, 'r');
 200             Pref   := Prefix (Pref);
 201             P_Name := Scope (P_Name);
 202          end loop;
 203
 204          --  The guard here on P_Name is to handle the error condition where
 205          --  the parent unit is missing because the file was not found.
 206
 207          if Present (P_Name) then
 208             Set_Entity (Pref, P_Name);
 209             Set_Etype (Pref, Etype (P_Name));
 210             Generate_Reference (P_Name, Pref, 'r');
 211             Style.Check_Identifier (Pref, P_Name);
 212          end if;
 213       end Generate_Parent_References;
 214
 215    --  Start of processing for Analyze_Compilation_Unit
 216
 217    begin
 218       Process_Compilation_Unit_Pragmas (N);
 219
 220       --  If the unit is a subunit whose parent has not been analyzed (which
 221       --  indicates that the main unit is a subunit, either the current one or
 222       --  one of its descendents) then the subunit is compiled as part of the
 223       --  analysis of the parent, which we proceed to do. Basically this gets
 224       --  handled from the top down and we don't want to do anything at this
 225       --  level (i.e. this subunit will be handled on the way down from the
 226       --  parent), so at this level we immediately return. If the subunit
 227       --  ends up not analyzed, it means that the parent did not contain a
 228       --  stub for it, or that there errors were dectected in some ancestor.
 229
 230       if Nkind (Unit_Node) = N_Subunit
 231         and then not Analyzed (Lib_Unit)
 232       then
 233          Semantics (Lib_Unit);
 234
 235          if not Analyzed (Proper_Body (Unit_Node)) then
 236             if Errors_Detected > 0 then
 237                Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
 238             else
 239                Error_Msg_N ("missing stub for subunit", N);
 240             end if;
 241          end if;
 242
 243          return;
 244       end if;
 245
 246       --  Analyze context (this will call Sem recursively for with'ed units)
 247
 248       Analyze_Context (N);
 249
 250       --  If the unit is a package body, the spec is already loaded and must
 251       --  be analyzed first, before we analyze the body.
 252
 253       if Nkind (Unit_Node) = N_Package_Body then
 254
 255          --  If no Lib_Unit, then there was a serious previous error, so
 256          --  just ignore the entire analysis effort
 257
 258          if No (Lib_Unit) then
 259             return;
 260
 261          else
 262             Semantics (Lib_Unit);
 263             Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
 264
 265             --  Verify that the library unit is a package declaration.
 266
 267             if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration
 268                  and then
 269                Nkind (Unit (Lib_Unit)) /= N_Generic_Package_Declaration
 270             then
 271                Error_Msg_N
 272                  ("no legal package declaration for package body", N);
 273                return;
 274
 275             --  Otherwise, the entity in the declaration is visible. Update
 276             --  the version to reflect dependence of this body on the spec.
 277
 278             else
 279                Spec_Id := Defining_Entity (Unit (Lib_Unit));
 280                Set_Is_Immediately_Visible (Spec_Id, True);
 281                Version_Update (N, Lib_Unit);
 282
 283                if Nkind (Defining_Unit_Name (Unit_Node))
 284                  = N_Defining_Program_Unit_Name
 285                then
 286                   Generate_Parent_References (Unit_Node, Scope (Spec_Id));
 287                end if;
 288             end if;
 289          end if;
 290
 291       --  If the unit is a subprogram body, then we similarly need to analyze
 292       --  its spec. However, things are a little simpler in this case, because
 293       --  here, this analysis is done only for error checking and consistency
 294       --  purposes, so there's nothing else to be done.
 295
 296       elsif Nkind (Unit_Node) = N_Subprogram_Body then
 297          if Acts_As_Spec (N) then
 298
 299             --  If the subprogram body is a child unit, we must create a
 300             --  declaration for it, in order to properly load the parent(s).
 301             --  After this, the original unit does not acts as a spec, because
 302             --  there is an explicit one. If this  unit appears in a context
 303             --  clause, then an implicit with on the parent will be added when
 304             --  installing the context. If this is the main unit, there is no
 305             --  Unit_Table entry for the declaration, (It has the unit number
 306             --  of the main unit) and code generation is unaffected.
 307
 308             Unum := Get_Cunit_Unit_Number (N);
 309             Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
 310
 311             if Par_Spec_Name /= No_Name then
 312                Unum :=
 313                  Load_Unit
 314                    (Load_Name  => Par_Spec_Name,
 315                     Required   => True,
 316                     Subunit    => False,
 317                     Error_Node => N);
 318
 319                if Unum /= No_Unit then
 320
 321                   --  Build subprogram declaration and attach parent unit to it
 322                   --  This subprogram declaration does not come from source!
 323
 324                   declare
 325                      Loc : constant Source_Ptr := Sloc (N);
 326                      SCS : constant Boolean :=
 327                              Get_Comes_From_Source_Default;
 328
 329                   begin
 330                      Set_Comes_From_Source_Default (False);
 331                      Lib_Unit :=
 332                        Make_Compilation_Unit (Loc,
 333                          Context_Items => New_Copy_List (Context_Items (N)),
 334                          Unit =>
 335                            Make_Subprogram_Declaration (Sloc (N),
 336                              Specification =>
 337                                Copy_Separate_Tree
 338                                  (Specification (Unit_Node))),
 339                          Aux_Decls_Node =>
 340                            Make_Compilation_Unit_Aux (Loc));
 341
 342                      Set_Library_Unit (N, Lib_Unit);
 343                      Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
 344                      Semantics (Lib_Unit);
 345                      Set_Acts_As_Spec (N, False);
 346                      Set_Comes_From_Source_Default (SCS);
 347                   end;
 348                end if;
 349             end if;
 350
 351          --  Here for subprogram with separate declaration
 352
 353          else
 354             Semantics (Lib_Unit);
 355             Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
 356             Version_Update (N, Lib_Unit);
 357          end if;
 358
 359          if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
 360                                              N_Defining_Program_Unit_Name
 361          then
 362             Generate_Parent_References (
 363               Specification (Unit_Node),
 364                 Scope (Defining_Entity (Unit (Lib_Unit))));
 365          end if;
 366       end if;
 367
 368       --  If it is a child unit, the parent must be elaborated first
 369       --  and we update version, since we are dependent on our parent.
 370
 371       if Is_Child_Spec (Unit_Node) then
 372
 373          --  The analysis of the parent is done with style checks off
 374
 375          declare
 376             Save_Style_Check : constant Boolean := Opt.Style_Check;
 377             Save_C_Restrict  : constant Save_Compilation_Unit_Restrictions :=
 378                                  Compilation_Unit_Restrictions_Save;
 379
 380          begin
 381             if not GNAT_Mode then
 382                Style_Check := False;
 383             end if;
 384
 385             Semantics (Parent_Spec (Unit_Node));
 386             Version_Update (N, Parent_Spec (Unit_Node));
 387             Style_Check := Save_Style_Check;
 388             Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
 389          end;
 390       end if;
 391
 392       --  With the analysis done, install the context. Note that we can't
 393       --  install the context from the with clauses as we analyze them,
 394       --  because each with clause must be analyzed in a clean visibility
 395       --  context, so we have to wait and install them all at once.
 396
 397       Install_Context (N);
 398
 399       if Is_Child_Spec (Unit_Node) then
 400
 401          --  Set the entities of all parents in the program_unit_name.
 402
 403          Generate_Parent_References (
 404            Unit_Node, Defining_Entity (Unit (Parent_Spec (Unit_Node))));
 405       end if;
 406
 407       --  All components of the context: with-clauses, library unit, ancestors
 408       --  if any, (and their context)  are analyzed and installed. Now analyze
 409       --  the unit itself, which is either a package, subprogram spec or body.
 410
 411       Analyze (Unit_Node);
 412
 413       --  The above call might have made Unit_Node an N_Subprogram_Body
 414       --  from something else, so propagate any Acts_As_Spec flag.
 415
 416       if Nkind (Unit_Node) = N_Subprogram_Body
 417         and then Acts_As_Spec (Unit_Node)
 418       then
 419          Set_Acts_As_Spec (N);
 420       end if;
 421
 422       --  Treat compilation unit pragmas that appear after the library unit
 423
 424       if Present (Pragmas_After (Aux_Decls_Node (N))) then
 425          declare
 426             Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
 427
 428          begin
 429             while Present (Prag_Node) loop
 430                Analyze (Prag_Node);
 431                Next (Prag_Node);
 432             end loop;
 433          end;
 434       end if;
 435
 436       --  Generate distribution stub files if requested and no error
 437
 438       if N = Main_Cunit
 439         and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
 440                     or else
 441                   Distribution_Stub_Mode = Generate_Caller_Stub_Body)
 442         and then not Fatal_Error (Main_Unit)
 443       then
 444          if Is_RCI_Pkg_Spec_Or_Body (N) then
 445
 446             --  Regular RCI package
 447
 448             Add_Stub_Constructs (N);
 449
 450          elsif (Nkind (Unit_Node) = N_Package_Declaration
 451                  and then Is_Shared_Passive (Defining_Entity
 452                                               (Specification (Unit_Node))))
 453            or else (Nkind (Unit_Node) = N_Package_Body
 454                      and then
 455                        Is_Shared_Passive (Corresponding_Spec (Unit_Node)))
 456          then
 457             --  Shared passive package
 458
 459             Add_Stub_Constructs (N);
 460
 461          elsif Nkind (Unit_Node) = N_Package_Instantiation
 462            and then
 463              Is_Remote_Call_Interface
 464                (Defining_Entity (Specification (Instance_Spec (Unit_Node))))
 465          then
 466             --  Instantiation of a RCI generic package
 467
 468             Add_Stub_Constructs (N);
 469          end if;
 470
 471          --  Reanalyze the unit with the new constructs
 472
 473          Analyze (Unit_Node);
 474       end if;
 475
 476       if Nkind (Unit_Node) = N_Package_Declaration
 477         or else Nkind (Unit_Node) in N_Generic_Declaration
 478         or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
 479         or else Nkind (Unit_Node) = N_Subprogram_Declaration
 480       then
 481          Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
 482
 483       elsif Nkind (Unit_Node) = N_Package_Body
 484         or else (Nkind (Unit_Node) = N_Subprogram_Body
 485                   and then not Acts_As_Spec (Unit_Node))
 486       then
 487          --  Bodies that are not the main unit are compiled if they
 488          --  are generic or contain generic or inlined units. Their
 489          --  analysis brings in the context of the corresponding spec
 490          --  (unit declaration) which must be removed as well, to
 491          --  return the compilation environment to its proper state.
 492
 493          Remove_Context (Lib_Unit);
 494          Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
 495       end if;
 496
 497       --  Last step is to deinstall the context we just installed
 498       --  as well as the unit just compiled.
 499
 500       Remove_Context (N);
 501
 502       --  If this is the main unit and we are generating code, we must
 503       --  check that all generic units in the context have a body if they
 504       --  need it, even if they have not been instantiated. In the absence
 505       --  of .ali files for generic units, we must force the load of the body,
 506       --  just to produce the proper error if the body is absent. We skip this
 507       --  verification if the main unit itself is generic.
 508
 509       if Get_Cunit_Unit_Number (N) = Main_Unit
 510         and then Operating_Mode = Generate_Code
 511         and then Expander_Active
 512       then
 513          --  Indicate that the main unit is now analyzed, to catch possible
 514          --  circularities between it and generic bodies. Remove main unit
 515          --  from visibility. This might seem superfluous, but the main unit
 516          --  must not be visible in the generic body expansions that follow.
 517
 518          Set_Analyzed (N, True);
 519          Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
 520
 521          declare
 522             Item  : Node_Id;
 523             Nam   : Entity_Id;
 524             Un    : Unit_Number_Type;
 525
 526             Save_Style_Check : constant Boolean := Opt.Style_Check;
 527             Save_C_Restrict  : constant Save_Compilation_Unit_Restrictions :=
 528                                  Compilation_Unit_Restrictions_Save;
 529
 530          begin
 531             Item := First (Context_Items (N));
 532
 533             while Present (Item) loop
 534
 535                if Nkind (Item) = N_With_Clause
 536                   and then not Implicit_With (Item)
 537                then
 538                   Nam := Entity (Name (Item));
 539
 540                   if (Ekind (Nam) = E_Generic_Procedure
 541                        and then not Is_Intrinsic_Subprogram (Nam))
 542                     or else (Ekind (Nam) = E_Generic_Function
 543                               and then not Is_Intrinsic_Subprogram (Nam))
 544                     or else (Ekind (Nam) = E_Generic_Package
 545                               and then Unit_Requires_Body (Nam))
 546                   then
 547                      Opt.Style_Check := False;
 548
 549                      if Present (Renamed_Object (Nam)) then
 550                         Un :=
 551                            Load_Unit
 552                              (Load_Name  => Get_Body_Name
 553                                               (Get_Unit_Name
 554                                                 (Unit_Declaration_Node
 555                                                   (Renamed_Object (Nam)))),
 556                               Required   => False,
 557                               Subunit    => False,
 558                               Error_Node => N,
 559                               Renamings  => True);
 560                      else
 561                         Un :=
 562                           Load_Unit
 563                             (Load_Name  => Get_Body_Name
 564                                              (Get_Unit_Name (Item)),
 565                              Required   => False,
 566                              Subunit    => False,
 567                              Error_Node => N,
 568                              Renamings  => True);
 569                      end if;
 570
 571                      if Un = No_Unit then
 572                         Error_Msg_NE
 573                           ("body of generic unit& not found", Item, Nam);
 574                         exit;
 575
 576                      elsif not Analyzed (Cunit (Un))
 577                        and then Un /= Main_Unit
 578                      then
 579                         Opt.Style_Check := False;
 580                         Semantics (Cunit (Un));
 581                      end if;
 582                   end if;
 583                end if;
 584
 585                Next (Item);
 586             end loop;
 587
 588             Style_Check := Save_Style_Check;
 589             Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
 590          end;
 591       end if;
 592
 593       --  Deal with creating elaboration Boolean if needed. We create an
 594       --  elaboration boolean only for units that come from source since
 595       --  units manufactured by the compiler never need elab checks.
 596
 597       if Comes_From_Source (N)
 598         and then
 599           (Nkind (Unit (N)) =  N_Package_Declaration         or else
 600            Nkind (Unit (N)) =  N_Generic_Package_Declaration or else
 601            Nkind (Unit (N)) =  N_Subprogram_Declaration      or else
 602            Nkind (Unit (N)) =  N_Generic_Subprogram_Declaration)
 603       then
 604          declare
 605             Loc  : constant Source_Ptr := Sloc (N);
 606             Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
 607
 608          begin
 609             Spec_Id := Defining_Entity (Unit (N));
 610             Generate_Definition (Spec_Id);
 611
 612             --  See if an elaboration entity is required for possible
 613             --  access before elaboration checking. Note that we must
 614             --  allow for this even if -gnatE is not set, since a client
 615             --  may be compiled in -gnatE mode and reference the entity.
 616
 617             --  Case of units which do not require elaboration checks
 618
 619             if
 620                --  Pure units do not need checks
 621
 622                  Is_Pure (Spec_Id)
 623
 624                --  Preelaborated units do not need checks
 625
 626                  or else Is_Preelaborated (Spec_Id)
 627
 628                --  No checks needed if pagma Elaborate_Body present
 629
 630                  or else Has_Pragma_Elaborate_Body (Spec_Id)
 631
 632                --  No checks needed if unit does not require a body
 633
 634                  or else not Unit_Requires_Body (Spec_Id)
 635
 636                --  No checks needed for predefined files
 637
 638                  or else Is_Predefined_File_Name (Unit_File_Name (Unum))
 639
 640                --  No checks required if no separate spec
 641
 642                  or else Acts_As_Spec (N)
 643             then
 644                --  This is a case where we only need the entity for
 645                --  checking to prevent multiple elaboration checks.
 646
 647                Set_Elaboration_Entity_Required (Spec_Id, False);
 648
 649             --  Case of elaboration entity is required for access before
 650             --  elaboration checking (so certainly we must build it!)
 651
 652             else
 653                Set_Elaboration_Entity_Required (Spec_Id, True);
 654             end if;
 655
 656             Build_Elaboration_Entity (N, Spec_Id);
 657          end;
 658       end if;
 659
 660       --  Finally, freeze the compilation unit entity. This for sure is needed
 661       --  because of some warnings that can be output (see Freeze_Subprogram),
 662       --  but may in general be required. If freezing actions result, place
 663       --  them in the compilation unit actions list, and analyze them.
 664
 665       declare
 666          Loc : constant Source_Ptr := Sloc (N);
 667          L   : constant List_Id :=
 668                  Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
 669
 670       begin
 671          while Is_Non_Empty_List (L) loop
 672             Insert_Library_Level_Action (Remove_Head (L));
 673          end loop;
 674       end;
 675
 676       Set_Analyzed (N);
 677
 678       if Nkind (Unit_Node) = N_Package_Declaration
 679         and then Get_Cunit_Unit_Number (N) /= Main_Unit
 680         and then Front_End_Inlining
 681         and then Expander_Active
 682       then
 683          Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
 684       end if;
 685    end Analyze_Compilation_Unit;
 686
 687    ---------------------
 688    -- Analyze_Context --
 689    ---------------------
 690
 691    procedure Analyze_Context (N : Node_Id) is
 692       Item  : Node_Id;
 693
 694    begin
 695       --  Loop through context items
 696
 697       Item := First (Context_Items (N));
 698       while Present (Item) loop
 699
 700          --  For with clause, analyze the with clause, and then update
 701          --  the version, since we are dependent on a unit that we with.
 702
 703          if Nkind (Item) = N_With_Clause then
 704
 705             --  Skip analyzing with clause if no unit, nothing to do (this
 706             --  happens for a with that references a non-existent unit)
 707
 708             if Present (Library_Unit (Item)) then
 709                Analyze (Item);
 710             end if;
 711
 712             if not Implicit_With (Item) then
 713                Version_Update (N, Library_Unit (Item));
 714             end if;
 715
 716          --  But skip use clauses at this stage, since we don't want to do
 717          --  any installing of potentially use visible entities until we
 718          --  we actually install the complete context (in Install_Context).
 719          --  Otherwise things can get installed in the wrong context.
 720          --  Similarly, pragmas are analyzed in Install_Context, after all
 721          --  the implicit with's on parent units are generated.
 722
 723          else
 724             null;
 725          end if;
 726
 727          Next (Item);
 728       end loop;
 729    end Analyze_Context;
 730
 731    -------------------------------
 732    -- Analyze_Package_Body_Stub --
 733    -------------------------------
 734
 735    procedure Analyze_Package_Body_Stub (N : Node_Id) is
 736       Id   : constant Entity_Id := Defining_Identifier (N);
 737       Nam  : Entity_Id;
 738
 739    begin
 740       --  The package declaration must be in the current declarative part.
 741
 742       Check_Stub_Level (N);
 743       Nam := Current_Entity_In_Scope (Id);
 744
 745       if No (Nam) or else not Is_Package (Nam) then
 746          Error_Msg_N ("missing specification for package stub", N);
 747
 748       elsif Has_Completion (Nam)
 749         and then Present (Corresponding_Body (Unit_Declaration_Node (Nam)))
 750       then
 751          Error_Msg_N ("duplicate or redundant stub for package", N);
 752
 753       else
 754          --  Indicate that the body of the package exists. If we are doing
 755          --  only semantic analysis, the stub stands for the body. If we are
 756          --  generating code, the existence of the body will be confirmed
 757          --  when we load the proper body.
 758
 759          Set_Has_Completion (Nam);
 760          Set_Scope (Defining_Entity (N), Current_Scope);
 761          Analyze_Proper_Body (N, Nam);
 762       end if;
 763    end Analyze_Package_Body_Stub;
 764
 765    -------------------------
 766    -- Analyze_Proper_Body --
 767    -------------------------
 768
 769    procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
 770       Subunit_Name      : constant Unit_Name_Type := Get_Unit_Name (N);
 771       Unum              : Unit_Number_Type;
 772       Subunit_Not_Found : Boolean := False;
 773
 774       procedure Optional_Subunit;
 775       --  This procedure is called when the main unit is a stub, or when we
 776       --  are not generating code. In such a case, we analyze the subunit if
 777       --  present, which is user-friendly and in fact required for ASIS, but
 778       --  we don't complain if the subunit is missing.
 779
 780       ----------------------
 781       -- Optional_Subunit --
 782       ----------------------
 783
 784       procedure Optional_Subunit is
 785          Comp_Unit : Node_Id;
 786
 787       begin
 788          --  Try to load subunit, but ignore any errors that occur during
 789          --  the loading of the subunit, by using the special feature in
 790          --  Errout to ignore all errors. Note that Fatal_Error will still
 791          --  be set, so we will be able to check for this case below.
 792
 793          Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
 794          Unum :=
 795            Load_Unit
 796              (Load_Name  => Subunit_Name,
 797               Required   => False,
 798               Subunit    => True,
 799               Error_Node => N);
 800          Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
 801
 802          --  All done if we successfully loaded the subunit
 803
 804          if Unum /= No_Unit and then not Fatal_Error (Unum) then
 805             Comp_Unit := Cunit (Unum);
 806
 807             Set_Corresponding_Stub (Unit (Comp_Unit), N);
 808             Analyze_Subunit (Comp_Unit);
 809             Set_Library_Unit (N, Comp_Unit);
 810
 811          elsif Unum = No_Unit
 812            and then Present (Nam)
 813          then
 814             if Is_Protected_Type (Nam) then
 815                Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N));
 816             else
 817                Set_Corresponding_Body (
 818                  Unit_Declaration_Node (Nam), Defining_Identifier (N));
 819             end if;
 820          end if;
 821       end Optional_Subunit;
 822
 823    --  Start of processing for Analyze_Proper_Body
 824
 825    begin
 826       --  If the subunit is already loaded, it means that the main unit
 827       --  is a subunit, and that the current unit is one of its parents
 828       --  which was being analyzed to provide the needed context for the
 829       --  analysis of the subunit. In this case we analyze the subunit and
 830       --  continue with the parent, without looking a subsequent subunits.
 831
 832       if Is_Loaded (Subunit_Name) then
 833
 834          --  If the proper body is already linked to the stub node,
 835          --  the stub is in a generic unit and just needs analyzing.
 836
 837          if Present (Library_Unit (N)) then
 838             Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
 839             Analyze_Subunit (Library_Unit (N));
 840
 841          --  Otherwise we must load the subunit and link to it
 842
 843          else
 844             --  Load the subunit, this must work, since we originally
 845             --  loaded the subunit earlier on. So this will not really
 846             --  load it, just give access to it.
 847
 848             Unum :=
 849               Load_Unit
 850                 (Load_Name  => Subunit_Name,
 851                  Required   => True,
 852                  Subunit    => False,
 853                  Error_Node => N);
 854
 855             --  And analyze the subunit in the parent context (note that we
 856             --  do not call Semantics, since that would remove the parent
 857             --  context). Because of this, we have to manually reset the
 858             --  compiler state to Analyzing since it got destroyed by Load.
 859
 860             if Unum /= No_Unit then
 861                Compiler_State := Analyzing;
 862                Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
 863                Analyze_Subunit (Cunit (Unum));
 864                Set_Library_Unit (N, Cunit (Unum));
 865             end if;
 866          end if;
 867
 868       --  If the main unit is a subunit, then we are just performing semantic
 869       --  analysis on that subunit, and any other subunits of any parent unit
 870       --  should be ignored, except that if we are building trees for ASIS
 871       --  usage we want to annotate the stub properly.
 872
 873       elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
 874         and then Subunit_Name /= Unit_Name (Main_Unit)
 875       then
 876          if Tree_Output then
 877             Optional_Subunit;
 878          end if;
 879
 880          --  But before we return, set the flag for unloaded subunits. This
 881          --  will suppress junk warnings of variables in the same declarative
 882          --  part (or a higher level one) that are in danger of looking unused
 883          --  when in fact there might be a declaration in the subunit that we
 884          --  do not intend to load.
 885
 886          Unloaded_Subunits := True;
 887          return;
 888
 889       --  If the subunit is not already loaded, and we are generating code,
 890       --  then this is the case where compilation started from the parent,
 891       --  and we are generating code for an entire subunit tree. In that
 892       --  case we definitely need to load the subunit.
 893
 894       --  In order to continue the analysis with the rest of the parent,
 895       --  and other subunits, we load the unit without requiring its
 896       --  presence, and emit a warning if not found, rather than terminating
 897       --  the compilation abruptly, as for other missing file problems.
 898
 899       elsif Operating_Mode = Generate_Code then
 900
 901          --  If the proper body is already linked to the stub node,
 902          --  the stub is in a generic unit and just needs analyzing.
 903
 904          --  We update the version. Although we are not technically
 905          --  semantically dependent on the subunit, given our approach
 906          --  of macro substitution of subunits, it makes sense to
 907          --  include it in the version identification.
 908
 909          if Present (Library_Unit (N)) then
 910             Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
 911             Analyze_Subunit (Library_Unit (N));
 912             Version_Update (Cunit (Main_Unit), Library_Unit (N));
 913
 914          --  Otherwise we must load the subunit and link to it
 915
 916          else
 917             Unum :=
 918               Load_Unit
 919                 (Load_Name  => Subunit_Name,
 920                  Required   => False,
 921                  Subunit    => True,
 922                  Error_Node => N);
 923
 924             if Operating_Mode = Generate_Code
 925               and then Unum = No_Unit
 926             then
 927                Error_Msg_Name_1 := Subunit_Name;
 928                Error_Msg_Name_2 :=
 929                  Get_File_Name (Subunit_Name, Subunit => True);
 930                Error_Msg_N
 931                  ("subunit% in file{ not found!?", N);
 932                Subunits_Missing := True;
 933                Subunit_Not_Found := True;
 934             end if;
 935
 936             --  Load_Unit may reset Compiler_State, since it may have been
 937             --  necessary to parse an additional units, so we make sure
 938             --  that we reset it to the Analyzing state.
 939
 940             Compiler_State := Analyzing;
 941
 942             if Unum /= No_Unit and then not Fatal_Error (Unum) then
 943
 944                if Debug_Flag_L then
 945                   Write_Str ("*** Loaded subunit from stub. Analyze");
 946                   Write_Eol;
 947                end if;
 948
 949                declare
 950                   Comp_Unit : constant Node_Id := Cunit (Unum);
 951
 952                begin
 953                   --  Check for child unit instead of subunit
 954
 955                   if Nkind (Unit (Comp_Unit)) /= N_Subunit then
 956                      Error_Msg_N
 957                        ("expected SEPARATE subunit, found child unit",
 958                         Cunit_Entity (Unum));
 959
 960                   --  OK, we have a subunit, so go ahead and analyze it,
 961                   --  and set Scope of entity in stub, for ASIS use.
 962
 963                   else
 964                      Set_Corresponding_Stub (Unit (Comp_Unit), N);
 965                      Analyze_Subunit (Comp_Unit);
 966                      Set_Library_Unit (N, Comp_Unit);
 967
 968                      --  We update the version. Although we are not technically
 969                      --  semantically dependent on the subunit, given our
 970                      --  approach of macro substitution of subunits, it makes
 971                      --  sense to include it in the version identification.
 972
 973                      Version_Update (Cunit (Main_Unit), Comp_Unit);
 974                   end if;
 975                end;
 976             end if;
 977          end if;
 978
 979          --  The remaining case is when the subunit is not already loaded and
 980          --  we are not generating code. In this case we are just performing
 981          --  semantic analysis on the parent, and we are not interested in
 982          --  the subunit. For subprograms, analyze the stub as a body. For
 983          --  other entities the stub has already been marked as completed.
 984
 985       else
 986          Optional_Subunit;
 987       end if;
 988
 989    end Analyze_Proper_Body;
 990
 991    ----------------------------------
 992    -- Analyze_Protected_Body_Stub --
 993    ----------------------------------
 994
 995    procedure Analyze_Protected_Body_Stub (N : Node_Id) is
 996       Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
 997
 998    begin
 999       Check_Stub_Level (N);
1000
1001       --  First occurrence of name may have been as an incomplete type.
1002
1003       if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
1004          Nam := Full_View (Nam);
1005       end if;
1006
1007       if No (Nam)
1008         or else not Is_Protected_Type (Etype (Nam))
1009       then
1010          Error_Msg_N ("missing specification for Protected body", N);
1011       else
1012          Set_Scope (Defining_Entity (N), Current_Scope);
1013          Set_Has_Completion (Etype (Nam));
1014          Analyze_Proper_Body (N, Etype (Nam));
1015       end if;
1016    end Analyze_Protected_Body_Stub;
1017
1018    ----------------------------------
1019    -- Analyze_Subprogram_Body_Stub --
1020    ----------------------------------
1021
1022    --  A subprogram body stub can appear with or without a previous
1023    --  specification. If there is one, the analysis of the body will
1024    --  find it and verify conformance.  The formals appearing in the
1025    --  specification of the stub play no role, except for requiring an
1026    --  additional conformance check. If there is no previous subprogram
1027    --  declaration, the stub acts as a spec, and provides the defining
1028    --  entity for the subprogram.
1029
1030    procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
1031       Decl : Node_Id;
1032
1033    begin
1034       Check_Stub_Level (N);
1035
1036       --  Verify that the identifier for the stub is unique within this
1037       --  declarative part.
1038
1039       if Nkind (Parent (N)) = N_Block_Statement
1040         or else Nkind (Parent (N)) = N_Package_Body
1041         or else Nkind (Parent (N)) = N_Subprogram_Body
1042       then
1043          Decl := First (Declarations (Parent (N)));
1044
1045          while Present (Decl)
1046            and then Decl /= N
1047          loop
1048             if Nkind (Decl) = N_Subprogram_Body_Stub
1049               and then (Chars (Defining_Unit_Name (Specification (Decl)))
1050                       = Chars (Defining_Unit_Name (Specification (N))))
1051             then
1052                Error_Msg_N ("identifier for stub is not unique", N);
1053             end if;
1054
1055             Next (Decl);
1056          end loop;
1057       end if;
1058
1059       --  Treat stub as a body, which checks conformance if there is a previous
1060       --  declaration, or else introduces entity and its signature.
1061
1062       Analyze_Subprogram_Body (N);
1063
1064       if Errors_Detected = 0 then
1065          Analyze_Proper_Body (N, Empty);
1066       end if;
1067
1068    end Analyze_Subprogram_Body_Stub;
1069
1070    ---------------------
1071    -- Analyze_Subunit --
1072    ---------------------
1073
1074    --  A subunit is compiled either by itself (for semantic checking)
1075    --  or as part of compiling the parent (for code generation). In
1076    --  either case, by the time we actually process the subunit, the
1077    --  parent has already been installed and analyzed. The node N is
1078    --  a compilation unit, whose context needs to be treated here,
1079    --  because we come directly here from the parent without calling
1080    --  Analyze_Compilation_Unit.
1081
1082    --  The compilation context includes the explicit context of the
1083    --  subunit, and the context of the parent, together with the parent
1084    --  itself. In order to compile the current context, we remove the
1085    --  one inherited from the parent, in order to have a clean visibility
1086    --  table. We restore the parent context before analyzing the proper
1087    --  body itself. On exit, we remove only the explicit context of the
1088    --  subunit.
1089
1090    procedure Analyze_Subunit (N : Node_Id) is
1091       Lib_Unit : constant Node_Id   := Library_Unit (N);
1092       Par_Unit : constant Entity_Id := Current_Scope;
1093
1094       Lib_Spec        : Node_Id := Library_Unit (Lib_Unit);
1095       Num_Scopes      : Int := 0;
1096       Use_Clauses     : array (1 .. Scope_Stack.Last) of Node_Id;
1097       Enclosing_Child : Entity_Id := Empty;
1098
1099       procedure Analyze_Subunit_Context;
1100       --  Capture names in use clauses of the subunit. This must be done
1101       --  before re-installing parent declarations, because items in the
1102       --  context must not be hidden by declarations local to the parent.
1103
1104       procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
1105       --  Recursive procedure to restore scope of all ancestors of subunit,
1106       --  from outermost in. If parent is not a subunit, the call to install
1107       --  context installs context of spec and (if parent is a child unit)
1108       --  the context of its parents as well. It is confusing that parents
1109       --  should be treated differently in both cases, but the semantics are
1110       --  just not identical.
1111
1112       procedure Re_Install_Use_Clauses;
1113       --  As part of the removal of the parent scope, the use clauses are
1114       --  removed, to be reinstalled when the context of the subunit has
1115       --  been analyzed. Use clauses may also have been affected by the
1116       --  analysis of the context of the subunit, so they have to be applied
1117       --  again, to insure that the compilation environment of the rest of
1118       --  the parent unit is identical.
1119
1120       procedure Remove_Scope;
1121       --  Remove current scope from scope stack, and preserve the list
1122       --  of use clauses in it, to be reinstalled after context is analyzed.
1123
1124       ------------------------------
1125       --  Analyze_Subunit_Context --
1126       ------------------------------
1127
1128       procedure Analyze_Subunit_Context is
1129          Item      :  Node_Id;
1130          Nam       :  Node_Id;
1131          Unit_Name : Entity_Id;
1132
1133       begin
1134          Analyze_Context (N);
1135          Item := First (Context_Items (N));
1136
1137          --  make withed units immediately visible. If child unit, make the
1138          --  ultimate parent immediately visible.
1139
1140          while Present (Item) loop
1141
1142             if Nkind (Item) = N_With_Clause then
1143                Unit_Name := Entity (Name (Item));
1144
1145                while Is_Child_Unit (Unit_Name) loop
1146                   Set_Is_Visible_Child_Unit (Unit_Name);
1147                   Unit_Name := Scope (Unit_Name);
1148                end loop;
1149
1150                if not Is_Immediately_Visible (Unit_Name) then
1151                   Set_Is_Immediately_Visible (Unit_Name);
1152                   Set_Context_Installed (Item);
1153                end if;
1154
1155             elsif Nkind (Item) = N_Use_Package_Clause then
1156                Nam := First (Names (Item));
1157
1158                while Present (Nam) loop
1159                   Analyze (Nam);
1160                   Next (Nam);
1161                end loop;
1162
1163             elsif Nkind (Item) = N_Use_Type_Clause then
1164                Nam := First (Subtype_Marks (Item));
1165
1166                while Present (Nam) loop
1167                   Analyze (Nam);
1168                   Next (Nam);
1169                end loop;
1170             end if;
1171
1172             Next (Item);
1173          end loop;
1174
1175          Item := First (Context_Items (N));
1176
1177          --  reset visibility of withed units. They will be made visible
1178          --  again when we install the subunit context.
1179
1180          while Present (Item) loop
1181
1182             if Nkind (Item) = N_With_Clause then
1183                Unit_Name := Entity (Name (Item));
1184
1185                while Is_Child_Unit (Unit_Name) loop
1186                   Set_Is_Visible_Child_Unit (Unit_Name, False);
1187                   Unit_Name := Scope (Unit_Name);
1188                end loop;
1189
1190                if Context_Installed (Item) then
1191                   Set_Is_Immediately_Visible (Unit_Name, False);
1192                   Set_Context_Installed (Item, False);
1193                end if;
1194             end if;
1195
1196             Next (Item);
1197          end loop;
1198
1199       end Analyze_Subunit_Context;
1200
1201       ------------------------
1202       -- Re_Install_Parents --
1203       ------------------------
1204
1205       procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is
1206          E : Entity_Id;
1207
1208       begin
1209          if Nkind (Unit (L)) = N_Subunit then
1210             Re_Install_Parents (Library_Unit (L), Scope (Scop));
1211          end if;
1212
1213          Install_Context (L);
1214
1215          --  If the subunit occurs within a child unit, we must restore the
1216          --  immediate visibility of any siblings that may occur in context.
1217
1218          if Present (Enclosing_Child) then
1219             Install_Siblings (Enclosing_Child, L);
1220          end if;
1221
1222          New_Scope (Scop);
1223
1224          if Scop /= Par_Unit then
1225             Set_Is_Immediately_Visible (Scop);
1226          end if;
1227
1228          E := First_Entity (Current_Scope);
1229
1230          while Present (E) loop
1231             Set_Is_Immediately_Visible (E);
1232             Next_Entity (E);
1233          end loop;
1234
1235          --  A subunit appears within a body, and for a nested subunits
1236          --  all the parents are bodies. Restore full visibility of their
1237          --  private entities.
1238
1239          if Ekind (Scop) = E_Package then
1240             Set_In_Package_Body (Scop);
1241             Install_Private_Declarations (Scop);
1242          end if;
1243       end Re_Install_Parents;
1244
1245       ----------------------------
1246       -- Re_Install_Use_Clauses --
1247       ----------------------------
1248
1249       procedure Re_Install_Use_Clauses is
1250          U  : Node_Id;
1251
1252       begin
1253          for J in reverse 1 .. Num_Scopes loop
1254             U := Use_Clauses (J);
1255             Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
1256             Install_Use_Clauses (U);
1257          end loop;
1258       end Re_Install_Use_Clauses;
1259
1260       ------------------
1261       -- Remove_Scope --
1262       ------------------
1263
1264       procedure Remove_Scope is
1265          E : Entity_Id;
1266
1267       begin
1268          Num_Scopes := Num_Scopes + 1;
1269          Use_Clauses (Num_Scopes) :=
1270                Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
1271          E := First_Entity (Current_Scope);
1272
1273          while Present (E) loop
1274             Set_Is_Immediately_Visible (E, False);
1275             Next_Entity (E);
1276          end loop;
1277
1278          if Is_Child_Unit (Current_Scope) then
1279             Enclosing_Child := Current_Scope;
1280          end if;
1281
1282          Pop_Scope;
1283       end Remove_Scope;
1284
1285    --  Start of processing for Analyze_Subunit
1286
1287    begin
1288       if not Is_Empty_List (Context_Items (N)) then
1289
1290          --  Save current use clauses.
1291
1292          Remove_Scope;
1293          Remove_Context (Lib_Unit);
1294
1295          --  Now remove parents and their context, including enclosing
1296          --  subunits and the outer parent body which is not a subunit.
1297
1298          if Present (Lib_Spec) then
1299             Remove_Context (Lib_Spec);
1300
1301             while Nkind (Unit (Lib_Spec)) = N_Subunit loop
1302                Lib_Spec := Library_Unit (Lib_Spec);
1303                Remove_Scope;
1304                Remove_Context (Lib_Spec);
1305             end loop;
1306
1307             if Nkind (Unit (Lib_Unit)) = N_Subunit then
1308                Remove_Scope;
1309             end if;
1310
1311             if Nkind (Unit (Lib_Spec)) = N_Package_Body then
1312                Remove_Context (Library_Unit (Lib_Spec));
1313             end if;
1314          end if;
1315
1316          Analyze_Subunit_Context;
1317          Re_Install_Parents (Lib_Unit, Par_Unit);
1318
1319          --  If the context includes a child unit of the parent of the
1320          --  subunit, the parent will have been removed from visibility,
1321          --  after compiling that cousin in the context. The visibility
1322          --  of the parent must be restored now. This also applies if the
1323          --  context includes another subunit of the same parent which in
1324          --  turn includes a child unit in its context.
1325
1326          if Ekind (Par_Unit) = E_Package then
1327             if not Is_Immediately_Visible (Par_Unit)
1328               or else (Present (First_Entity (Par_Unit))
1329                         and then not Is_Immediately_Visible
1330                                       (First_Entity (Par_Unit)))
1331             then
1332                Set_Is_Immediately_Visible   (Par_Unit);
1333                Install_Visible_Declarations (Par_Unit);
1334                Install_Private_Declarations (Par_Unit);
1335             end if;
1336          end if;
1337
1338          Re_Install_Use_Clauses;
1339          Install_Context (N);
1340
1341          --  If the subunit is within a child unit, then siblings of any
1342          --  parent unit that appear in the context clause of the subunit
1343          --  must also be made immediately visible.
1344
1345          if Present (Enclosing_Child) then
1346             Install_Siblings (Enclosing_Child, N);
1347          end if;
1348
1349       end if;
1350
1351       Analyze (Proper_Body (Unit (N)));
1352       Remove_Context (N);
1353
1354    end Analyze_Subunit;
1355
1356    ----------------------------
1357    -- Analyze_Task_Body_Stub --
1358    ----------------------------
1359
1360    procedure Analyze_Task_Body_Stub (N : Node_Id) is
1361       Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
1362       Loc : constant Source_Ptr := Sloc (N);
1363
1364    begin
1365       Check_Stub_Level (N);
1366
1367       --  First occurrence of name may have been as an incomplete type.
1368
1369       if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
1370          Nam := Full_View (Nam);
1371       end if;
1372
1373       if No (Nam)
1374         or else not Is_Task_Type (Etype (Nam))
1375       then
1376          Error_Msg_N ("missing specification for task body", N);
1377       else
1378          Set_Scope (Defining_Entity (N), Current_Scope);
1379          Set_Has_Completion (Etype (Nam));
1380          Analyze_Proper_Body (N, Etype (Nam));
1381
1382          --  Set elaboration flag to indicate that entity is callable.
1383          --  This cannot be done in the expansion of the body  itself,
1384          --  because the proper body is not in a declarative part. This
1385          --  is only done if expansion is active, because the context
1386          --  may be generic and the flag not defined yet.
1387
1388          if Expander_Active then
1389             Insert_After (N,
1390               Make_Assignment_Statement (Loc,
1391                 Name =>
1392                   Make_Identifier (Loc,
1393                     New_External_Name (Chars (Etype (Nam)), 'E')),
1394                  Expression => New_Reference_To (Standard_True, Loc)));
1395          end if;
1396
1397       end if;
1398    end Analyze_Task_Body_Stub;
1399
1400    -------------------------
1401    -- Analyze_With_Clause --
1402    -------------------------
1403
1404    --  Analyze the declaration of a unit in a with clause. At end,
1405    --  label the with clause with the defining entity for the unit.
1406
1407    procedure Analyze_With_Clause (N : Node_Id) is
1408       Unit_Kind : constant Node_Kind := Nkind (Unit (Library_Unit (N)));
1409       E_Name    : Entity_Id;
1410       Par_Name  : Entity_Id;
1411       Pref      : Node_Id;
1412       U         : Node_Id;
1413
1414       Intunit : Boolean;
1415       --  Set True if the unit currently being compiled is an internal unit
1416
1417       Save_Style_Check : constant Boolean := Opt.Style_Check;
1418       Save_C_Restrict  : constant Save_Compilation_Unit_Restrictions :=
1419                            Compilation_Unit_Restrictions_Save;
1420
1421    begin
1422       --  We reset ordinary style checking during the analysis of a with'ed
1423       --  unit, but we do NOT reset GNAT special analysis mode (the latter
1424       --  definitely *does* apply to with'ed units).
1425
1426       if not GNAT_Mode then
1427          Style_Check := False;
1428       end if;
1429
1430       --  If the library unit is a predefined unit, and we are in no
1431       --  run time mode, then temporarily reset No_Run_Time mode for the
1432       --  analysis of the with'ed unit. The No_Run_Time pragma does not
1433       --  prevent explicit with'ing of run-time units.
1434
1435       if No_Run_Time
1436         and then
1437           Is_Predefined_File_Name
1438             (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
1439       then
1440          No_Run_Time := False;
1441          Semantics (Library_Unit (N));
1442          No_Run_Time := True;
1443
1444       else
1445          Semantics (Library_Unit (N));
1446       end if;
1447
1448       U := Unit (Library_Unit (N));
1449       Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
1450
1451       --  Following checks are skipped for dummy packages (those supplied
1452       --  for with's where no matching file could be found). Such packages
1453       --  are identified by the Sloc value being set to No_Location
1454
1455       if Sloc (U) /= No_Location then
1456
1457          --  Check restrictions, except that we skip the check if this
1458          --  is an internal unit unless we are compiling the internal
1459          --  unit as the main unit. We also skip this for dummy packages.
1460
1461          if not Intunit or else Current_Sem_Unit = Main_Unit then
1462             Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N);
1463          end if;
1464
1465          --  Check for inappropriate with of internal implementation unit
1466          --  if we are currently compiling the main unit and the main unit
1467          --  is itself not an internal unit.
1468
1469          if Implementation_Unit_Warnings
1470            and then Current_Sem_Unit = Main_Unit
1471            and then Implementation_Unit (Get_Source_Unit (U))
1472            and then not Intunit
1473          then
1474             Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
1475             Error_Msg_N
1476               ("\use of this unit is non-portable and version-dependent?",
1477                Name (N));
1478          end if;
1479       end if;
1480
1481       --  Semantic analysis of a generic unit is performed on a copy of
1482       --  the original tree. Retrieve the entity on  which semantic info
1483       --  actually appears.
1484
1485       if Unit_Kind in N_Generic_Declaration then
1486          E_Name := Defining_Entity (U);
1487
1488       --  Note: in the following test, Unit_Kind is the original Nkind, but
1489       --  in the case of an instantiation, the call to Semantics above will
1490       --  have replaced the unit by its instantiated version.
1491
1492       elsif Unit_Kind = N_Package_Instantiation
1493         and then Nkind (U) = N_Package_Body
1494       then
1495          --  Instantiation node is replaced with body of instance.
1496          --  Unit name is defining unit name in corresponding spec.
1497
1498          E_Name := Corresponding_Spec (U);
1499
1500       elsif Unit_Kind = N_Package_Instantiation
1501         and then Nkind (U) = N_Package_Instantiation
1502       then
1503          --  If the instance has not been rewritten as a package declaration,
1504          --  then it appeared already in a previous with clause. Retrieve
1505          --  the entity from the previous instance.
1506
1507          E_Name := Defining_Entity (Specification (Instance_Spec (U)));
1508
1509       elsif Unit_Kind = N_Procedure_Instantiation
1510         or else Unit_Kind = N_Function_Instantiation
1511       then
1512          --  Instantiation node is replaced with a package that contains
1513          --  renaming declarations and instance itself. The subprogram
1514          --  Instance is declared in the visible part of the wrapper package.
1515
1516          E_Name := First_Entity (Defining_Entity (U));
1517
1518          while Present (E_Name) loop
1519             exit when Is_Subprogram (E_Name)
1520               and then Is_Generic_Instance (E_Name);
1521             E_Name := Next_Entity (E_Name);
1522          end loop;
1523
1524       elsif Unit_Kind = N_Package_Renaming_Declaration
1525         or else Unit_Kind in N_Generic_Renaming_Declaration
1526       then
1527          E_Name := Defining_Entity (U);
1528
1529       elsif Unit_Kind = N_Subprogram_Body
1530         and then Nkind (Name (N)) = N_Selected_Component
1531         and then not Acts_As_Spec (Library_Unit (N))
1532       then
1533          --  For a child unit that has no spec, one has been created and
1534          --  analyzed. The entity required is that of the spec.
1535
1536          E_Name := Corresponding_Spec (U);
1537
1538       else
1539          E_Name := Defining_Entity (U);
1540       end if;
1541
1542       if Nkind (Name (N)) = N_Selected_Component then
1543
1544          --  Child unit in a with clause
1545
1546          Change_Selected_Component_To_Expanded_Name (Name (N));
1547       end if;
1548
1549       --  Restore style checks and restrictions
1550
1551       Style_Check := Save_Style_Check;
1552       Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
1553
1554       --  Record the reference, but do NOT set the unit as referenced, we
1555       --  want to consider the unit as unreferenced if this is the only
1556       --  reference that occurs.
1557
1558       Set_Entity_With_Style_Check (Name (N), E_Name);
1559       Generate_Reference (E_Name, Name (N), Set_Ref => False);
1560
1561       if Is_Child_Unit (E_Name) then
1562          Pref     := Prefix (Name (N));
1563          Par_Name := Scope (E_Name);
1564
1565          while Nkind (Pref) = N_Selected_Component loop
1566             Change_Selected_Component_To_Expanded_Name (Pref);
1567             Set_Entity_With_Style_Check (Pref, Par_Name);
1568
1569             Generate_Reference (Par_Name, Pref);
1570             Pref := Prefix (Pref);
1571             Par_Name := Scope (Par_Name);
1572          end loop;
1573
1574          if Present (Entity (Pref))
1575            and then not Analyzed (Parent (Parent (Entity (Pref))))
1576          then
1577             --  If the entity is set without its unit being compiled,
1578             --  the original parent is a renaming, and Par_Name is the
1579             --  renamed entity. For visibility purposes, we need the
1580             --  original entity, which must be analyzed now, because
1581             --  Load_Unit retrieves directly the renamed unit, and the
1582             --  renaming declaration itself has not been analyzed.
1583
1584             Analyze (Parent (Parent (Entity (Pref))));
1585             pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
1586             Par_Name := Entity (Pref);
1587          end if;
1588
1589          Set_Entity_With_Style_Check (Pref, Par_Name);
1590          Generate_Reference (Par_Name, Pref);
1591       end if;
1592
1593       --  If the withed unit is System, and a system extension pragma is
1594       --  present, compile the extension now, rather than waiting for
1595       --  a visibility check on a specific entity.
1596
1597       if Chars (E_Name) = Name_System
1598         and then Scope (E_Name) = Standard_Standard
1599         and then Present (System_Extend_Pragma_Arg)
1600         and then Present_System_Aux (N)
1601       then
1602          --  If the extension is not present, an error will have been emitted.
1603
1604          null;
1605       end if;
1606    end Analyze_With_Clause;
1607
1608    ------------------------------
1609    -- Analyze_With_Type_Clause --
1610    ------------------------------
1611
1612    procedure Analyze_With_Type_Clause (N : Node_Id) is
1613       Loc  : constant Source_Ptr := Sloc (N);
1614       Nam  : Node_Id := Name (N);
1615       Pack : Node_Id;
1616       Decl : Node_Id;
1617       P    : Entity_Id;
1618       Unum : Unit_Number_Type;
1619       Sel  : Node_Id;
1620
1621       procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind);
1622       --  Set basic attributes of type, including its class_wide type.
1623
1624       function In_Chain (E : Entity_Id) return Boolean;
1625       --  Check that the imported type is not already in the homonym chain,
1626       --  for example through a with_type clause in a parent unit.
1627
1628       --------------------------
1629       -- Decorate_Tagged_Type --
1630       --------------------------
1631
1632       procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind) is
1633          CW : Entity_Id;
1634
1635       begin
1636          Set_Ekind (T, E_Record_Type);
1637          Set_Is_Tagged_Type (T);
1638          Set_Etype (T, T);
1639          Set_From_With_Type (T);
1640          Set_Scope (T, P);
1641
1642          if not In_Chain (T) then
1643             Set_Homonym (T, Current_Entity (T));
1644             Set_Current_Entity (T);
1645          end if;
1646
1647          --  Build bogus class_wide type, if not previously done.
1648
1649          if No (Class_Wide_Type (T)) then
1650             CW := Make_Defining_Identifier (Loc,  New_Internal_Name ('S'));
1651
1652             Set_Ekind            (CW, E_Class_Wide_Type);
1653             Set_Etype            (CW, T);
1654             Set_Scope            (CW, P);
1655             Set_Is_Tagged_Type   (CW);
1656             Set_Is_First_Subtype (CW, True);
1657             Init_Size_Align      (CW);
1658             Set_Has_Unknown_Discriminants
1659                                  (CW, True);
1660             Set_Class_Wide_Type  (CW, CW);
1661             Set_Equivalent_Type  (CW, Empty);
1662             Set_From_With_Type   (CW);
1663
1664             Set_Class_Wide_Type (T, CW);
1665          end if;
1666       end Decorate_Tagged_Type;
1667
1668       --------------
1669       -- In_Chain --
1670       --------------
1671
1672       function In_Chain (E : Entity_Id) return Boolean is
1673          H : Entity_Id := Current_Entity (E);
1674
1675       begin
1676          while Present (H) loop
1677
1678             if H = E then
1679                return True;
1680             else
1681                H := Homonym (H);
1682             end if;
1683          end loop;
1684
1685          return False;
1686       end In_Chain;
1687
1688    --  Start of processing for Analyze_With_Type_Clause
1689
1690    begin
1691       if Nkind (Nam) = N_Selected_Component then
1692          Pack := New_Copy_Tree (Prefix (Nam));
1693          Sel  := Selector_Name (Nam);
1694
1695       else
1696          Error_Msg_N ("illegal name for imported type", Nam);
1697          return;
1698       end if;
1699
1700       Decl :=
1701         Make_Package_Declaration (Loc,
1702           Specification =>
1703              (Make_Package_Specification (Loc,
1704                Defining_Unit_Name   => Pack,
1705                Visible_Declarations => New_List,
1706                End_Label            => Empty)));
1707
1708       Unum :=
1709         Load_Unit
1710           (Load_Name  => Get_Unit_Name (Decl),
1711            Required   => True,
1712            Subunit    => False,
1713            Error_Node => Nam);
1714
1715       if Unum = No_Unit
1716          or else Nkind (Unit (Cunit (Unum))) /= N_Package_Declaration
1717       then
1718          Error_Msg_N ("imported type must be declared in package", Nam);
1719          return;
1720
1721       elsif Unum = Current_Sem_Unit then
1722
1723          --  If type is defined in unit being analyzed, then the clause
1724          --  is redundant.
1725
1726          return;
1727
1728       else
1729          P := Cunit_Entity (Unum);
1730       end if;
1731
1732       --  Find declaration for imported type, and set its basic attributes
1733       --  if it has not been analyzed (which will be the case if there is
1734       --  circular dependence).
1735
1736       declare
1737          Decl : Node_Id;
1738          Typ  : Entity_Id;
1739
1740       begin
1741          if not Analyzed (Cunit (Unum))
1742            and then not From_With_Type (P)
1743          then
1744             Set_Ekind (P, E_Package);
1745             Set_Etype (P, Standard_Void_Type);
1746             Set_From_With_Type (P);
1747             Set_Scope (P, Standard_Standard);
1748             Set_Homonym (P, Current_Entity (P));
1749             Set_Current_Entity (P);
1750
1751          elsif Analyzed (Cunit (Unum))
1752            and then Is_Child_Unit (P)
1753          then
1754             --  If the child unit is already in scope, indicate that it is
1755             --  visible, and remains so after intervening calls to rtsfind.
1756
1757             Set_Is_Visible_Child_Unit (P);
1758          end if;
1759
1760          if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then
1761
1762             --  Make parent packages visible.
1763
1764             declare
1765                Parent_Comp : Node_Id;
1766                Parent_Id   : Entity_Id;
1767                Child       : Entity_Id;
1768
1769             begin
1770                Child   := P;
1771                Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
1772
1773                loop
1774                   Parent_Id := Defining_Entity (Unit (Parent_Comp));
1775                   Set_Scope (Child, Parent_Id);
1776
1777                   --  The type may be imported from a child unit, in which
1778                   --  case the current compilation appears in the name. Do
1779                   --  not change its visibility here because it will conflict
1780                   --  with the subsequent normal processing.
1781
1782                   if not Analyzed (Unit_Declaration_Node (Parent_Id))
1783                     and then Parent_Id /= Cunit_Entity (Current_Sem_Unit)
1784                   then
1785                      Set_Ekind (Parent_Id, E_Package);
1786                      Set_Etype (Parent_Id, Standard_Void_Type);
1787
1788                      --  The same package may appear is several with_type
1789                      --  clauses.
1790
1791                      if not From_With_Type (Parent_Id) then
1792                         Set_Homonym (Parent_Id, Current_Entity (Parent_Id));
1793                         Set_Current_Entity (Parent_Id);
1794                         Set_From_With_Type (Parent_Id);
1795                      end if;
1796                   end if;
1797
1798                   Set_Is_Immediately_Visible (Parent_Id);
1799
1800                   Child := Parent_Id;
1801                   Parent_Comp := Parent_Spec (Unit (Parent_Comp));
1802                   exit when No (Parent_Comp);
1803                end loop;
1804
1805                Set_Scope (Parent_Id, Standard_Standard);
1806             end;
1807          end if;
1808
1809          --  Even if analyzed, the package may not be currently visible. It
1810          --  must be while the with_type clause is active.
1811
1812          Set_Is_Immediately_Visible (P);
1813
1814          Decl :=
1815            First (Visible_Declarations (Specification (Unit (Cunit (Unum)))));
1816
1817          while Present (Decl) loop
1818
1819             if Nkind (Decl) = N_Full_Type_Declaration
1820               and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
1821             then
1822                Typ := Defining_Identifier (Decl);
1823
1824                if Tagged_Present (N) then
1825
1826                   --  The declaration must indicate that this is a tagged
1827                   --  type or a type extension.
1828
1829                   if (Nkind (Type_Definition (Decl)) = N_Record_Definition
1830                        and then Tagged_Present (Type_Definition (Decl)))
1831                     or else
1832                       (Nkind (Type_Definition (Decl))
1833                           = N_Derived_Type_Definition
1834                          and then Present
1835                            (Record_Extension_Part (Type_Definition (Decl))))
1836                   then
1837                      null;
1838                   else
1839                      Error_Msg_N ("imported type is not a tagged type", Nam);
1840                      return;
1841                   end if;
1842
1843                   if not Analyzed (Decl) then
1844
1845                      --  Unit is not currently visible. Add basic attributes
1846                      --  to type and build its class-wide type.
1847
1848                      Init_Size_Align (Typ);
1849                      Decorate_Tagged_Type (Typ, E_Record_Type);
1850                   end if;
1851
1852                else
1853                   if Nkind (Type_Definition (Decl))
1854                      /= N_Access_To_Object_Definition
1855                   then
1856                      Error_Msg_N
1857                       ("imported type is not an access type", Nam);
1858
1859                   elsif not Analyzed (Decl) then
1860                      Set_Ekind                    (Typ, E_Access_Type);
1861                      Set_Etype                    (Typ, Typ);
1862                      Set_Scope                    (Typ, P);
1863                      Init_Size                    (Typ, System_Address_Size);
1864                      Init_Alignment               (Typ);
1865                      Set_Directly_Designated_Type (Typ, Standard_Integer);
1866                      Set_From_With_Type           (Typ);
1867
1868                      if not In_Chain (Typ) then
1869                         Set_Homonym               (Typ, Current_Entity (Typ));
1870                         Set_Current_Entity        (Typ);
1871                      end if;
1872                   end if;
1873                end if;
1874
1875                Set_Entity (Sel, Typ);
1876                return;
1877
1878             elsif ((Nkind (Decl) = N_Private_Type_Declaration
1879                       and then Tagged_Present (Decl))
1880                 or else (Nkind (Decl) = N_Private_Extension_Declaration))
1881               and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
1882             then
1883                Typ := Defining_Identifier (Decl);
1884
1885                if not Tagged_Present (N) then
1886                   Error_Msg_N ("type must be declared tagged", N);
1887
1888                elsif not Analyzed (Decl) then
1889                   Decorate_Tagged_Type (Typ, E_Private_Type);
1890                end if;
1891
1892                Set_Entity (Sel, Typ);
1893                Set_From_With_Type (Typ);
1894                return;
1895             end if;
1896
1897             Decl := Next (Decl);
1898          end loop;
1899
1900          Error_Msg_NE ("not a visible access or tagged type in&", Nam, P);
1901       end;
1902    end Analyze_With_Type_Clause;
1903
1904    -----------------------------
1905    -- Check_With_Type_Clauses --
1906    -----------------------------
1907
1908    procedure Check_With_Type_Clauses (N : Node_Id) is
1909       Lib_Unit : constant Node_Id := Unit (N);
1910
1911       procedure Check_Parent_Context (U : Node_Id);
1912       --  Examine context items of parent unit to locate with_type clauses.
1913
1914       --------------------------
1915       -- Check_Parent_Context --
1916       --------------------------
1917
1918       procedure Check_Parent_Context (U : Node_Id) is
1919          Item : Node_Id;
1920
1921       begin
1922          Item := First (Context_Items (U));
1923          while Present (Item) loop
1924             if Nkind (Item) = N_With_Type_Clause
1925               and then not Error_Posted (Item)
1926               and then
1927                 From_With_Type (Scope (Entity (Selector_Name (Name (Item)))))
1928             then
1929                Error_Msg_Sloc := Sloc (Item);
1930                Error_Msg_N ("Missing With_Clause for With_Type_Clause#", N);
1931             end if;
1932
1933             Next (Item);
1934          end loop;
1935       end Check_Parent_Context;
1936
1937    --  Start of processing for Check_With_Type_Clauses
1938
1939    begin
1940       if Extensions_Allowed
1941         and then (Nkind (Lib_Unit) = N_Package_Body
1942                    or else Nkind (Lib_Unit) = N_Subprogram_Body)
1943       then
1944          Check_Parent_Context (Library_Unit (N));
1945          if Is_Child_Spec (Unit (Library_Unit (N))) then
1946             Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N))));
1947          end if;
1948       end if;
1949    end Check_With_Type_Clauses;
1950
1951    ------------------------------
1952    -- Check_Private_Child_Unit --
1953    ------------------------------
1954
1955    procedure Check_Private_Child_Unit (N : Node_Id) is
1956       Lib_Unit   : constant Node_Id := Unit (N);
1957       Item       : Node_Id;
1958       Curr_Unit  : Entity_Id;
1959       Sub_Parent : Node_Id;
1960       Priv_Child : Entity_Id;
1961       Par_Lib    : Entity_Id;
1962       Par_Spec   : Node_Id;
1963
1964       function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean;
1965       --  Returns true if and only if the library unit is declared with
1966       --  an explicit designation of private.
1967
1968       function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
1969       begin
1970          return Private_Present (Parent (Unit_Declaration_Node (Unit)));
1971       end Is_Private_Library_Unit;
1972
1973    --  Start of processing for Check_Private_Child_Unit
1974
1975    begin
1976       if Nkind (Lib_Unit) = N_Package_Body
1977         or else Nkind (Lib_Unit) = N_Subprogram_Body
1978       then
1979          Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
1980          Par_Lib   := Curr_Unit;
1981
1982       elsif Nkind (Lib_Unit) = N_Subunit then
1983
1984          --  The parent is itself a body. The parent entity is to be found
1985          --  in the corresponding spec.
1986
1987          Sub_Parent := Library_Unit (N);
1988          Curr_Unit  := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
1989
1990          --  If the parent itself is a subunit, Curr_Unit is the entity
1991          --  of the enclosing body, retrieve the spec entity which is
1992          --  the proper ancestor we need for the following tests.
1993
1994          if Ekind (Curr_Unit) = E_Package_Body then
1995             Curr_Unit := Spec_Entity (Curr_Unit);
1996          end if;
1997
1998          Par_Lib    := Curr_Unit;
1999
2000       else
2001          Curr_Unit := Defining_Entity (Lib_Unit);
2002
2003          Par_Lib := Curr_Unit;
2004          Par_Spec  := Parent_Spec (Lib_Unit);
2005
2006          if No (Par_Spec) then
2007             Par_Lib := Empty;
2008          else
2009             Par_Lib := Defining_Entity (Unit (Par_Spec));
2010          end if;
2011       end if;
2012
2013       --  Loop through context items
2014
2015       Item := First (Context_Items (N));
2016       while Present (Item) loop
2017
2018          if Nkind (Item) = N_With_Clause
2019             and then not Implicit_With (Item)
2020             and then Is_Private_Descendant (Entity (Name (Item)))
2021          then
2022             Priv_Child := Entity (Name (Item));
2023
2024             declare
2025                Curr_Parent  : Entity_Id := Par_Lib;
2026                Child_Parent : Entity_Id := Scope (Priv_Child);
2027                Prv_Ancestor : Entity_Id := Child_Parent;
2028                Curr_Private : Boolean   := Is_Private_Library_Unit (Curr_Unit);
2029
2030             begin
2031                --  If the child unit is a public child then locate
2032                --  the nearest private ancestor; Child_Parent will
2033                --  then be set to the parent of that ancestor.
2034
2035                if not Is_Private_Library_Unit (Priv_Child) then
2036                   while Present (Prv_Ancestor)
2037                     and then not Is_Private_Library_Unit (Prv_Ancestor)
2038                   loop
2039                      Prv_Ancestor := Scope (Prv_Ancestor);
2040                   end loop;
2041
2042                   if Present (Prv_Ancestor) then
2043                      Child_Parent := Scope (Prv_Ancestor);
2044                   end if;
2045                end if;
2046
2047                while Present (Curr_Parent)
2048                  and then Curr_Parent /= Standard_Standard
2049                  and then Curr_Parent /= Child_Parent
2050                loop
2051                   Curr_Private :=
2052                     Curr_Private or else Is_Private_Library_Unit (Curr_Parent);
2053                   Curr_Parent := Scope (Curr_Parent);
2054                end loop;
2055
2056                if not Present (Curr_Parent) then
2057                   Curr_Parent := Standard_Standard;
2058                end if;
2059
2060                if Curr_Parent /= Child_Parent then
2061
2062                   if Ekind (Priv_Child) = E_Generic_Package
2063                     and then Chars (Priv_Child) in Text_IO_Package_Name
2064                     and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
2065                   then
2066                      Error_Msg_NE
2067                        ("& is a nested package, not a compilation unit",
2068                        Name (Item), Priv_Child);
2069
2070                   else
2071                      Error_Msg_N
2072                        ("unit in with clause is private child unit!", Item);
2073                      Error_Msg_NE
2074                        ("current unit must also have parent&!",
2075                         Item, Child_Parent);
2076                   end if;
2077
2078                elsif not Curr_Private
2079                  and then Nkind (Lib_Unit) /= N_Package_Body
2080                  and then Nkind (Lib_Unit) /= N_Subprogram_Body
2081                  and then Nkind (Lib_Unit) /= N_Subunit
2082                then
2083                   Error_Msg_NE
2084                     ("current unit must also be private descendant of&",
2085                      Item, Child_Parent);
2086                end if;
2087             end;
2088          end if;
2089
2090          Next (Item);
2091       end loop;
2092
2093    end Check_Private_Child_Unit;
2094
2095    ----------------------
2096    -- Check_Stub_Level --
2097    ----------------------
2098
2099    procedure Check_Stub_Level (N : Node_Id) is
2100       Par  : constant Node_Id   := Parent (N);
2101       Kind : constant Node_Kind := Nkind (Par);
2102
2103    begin
2104       if (Kind = N_Package_Body
2105            or else Kind = N_Subprogram_Body
2106            or else Kind = N_Task_Body
2107            or else Kind = N_Protected_Body)
2108
2109         and then (Nkind (Parent (Par)) = N_Compilation_Unit
2110                    or else Nkind (Parent (Par)) = N_Subunit)
2111       then
2112          null;
2113
2114       --  In an instance, a missing stub appears at any level. A warning
2115       --  message will have been emitted already for the missing file.
2116
2117       elsif not In_Instance then
2118          Error_Msg_N ("stub cannot appear in an inner scope", N);
2119
2120       elsif Expander_Active then
2121          Error_Msg_N ("missing proper body", N);
2122       end if;
2123    end Check_Stub_Level;
2124
2125    ------------------------
2126    -- Expand_With_Clause --
2127    ------------------------
2128
2129    procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id) is
2130       Loc   : constant Source_Ptr := Sloc (Nam);
2131       Ent   : constant Entity_Id := Entity (Nam);
2132       Withn : Node_Id;
2133       P     : Node_Id;
2134
2135       function Build_Unit_Name (Nam : Node_Id) return Node_Id;
2136
2137       function Build_Unit_Name (Nam : Node_Id) return Node_Id is
2138          Result : Node_Id;
2139
2140       begin
2141          if Nkind (Nam) = N_Identifier then
2142             return New_Occurrence_Of (Entity (Nam), Loc);
2143
2144          else
2145             Result :=
2146               Make_Expanded_Name (Loc,
2147                 Chars  => Chars (Entity (Nam)),
2148                 Prefix => Build_Unit_Name (Prefix (Nam)),
2149                 Selector_Name => New_Occurrence_Of (Entity (Nam), Loc));
2150             Set_Entity (Result, Entity (Nam));
2151             return Result;
2152          end if;
2153       end Build_Unit_Name;
2154
2155    begin
2156       New_Nodes_OK := New_Nodes_OK + 1;
2157       Withn :=
2158         Make_With_Clause (Loc, Name => Build_Unit_Name (Nam));
2159
2160       P := Parent (Unit_Declaration_Node (Ent));
2161       Set_Library_Unit          (Withn, P);
2162       Set_Corresponding_Spec    (Withn, Ent);
2163       Set_First_Name            (Withn, True);
2164       Set_Implicit_With         (Withn, True);
2165
2166       Prepend (Withn, Context_Items (N));
2167       Mark_Rewrite_Insertion (Withn);
2168       Install_Withed_Unit (Withn);
2169
2170       if Nkind (Nam) = N_Expanded_Name then
2171          Expand_With_Clause (Prefix (Nam), N);
2172       end if;
2173
2174       New_Nodes_OK := New_Nodes_OK - 1;
2175    end Expand_With_Clause;
2176
2177    -----------------------------
2178    -- Implicit_With_On_Parent --
2179    -----------------------------
2180
2181    procedure Implicit_With_On_Parent
2182      (Child_Unit : Node_Id;
2183       N          : Node_Id)
2184    is
2185       Loc    : constant Source_Ptr := Sloc (N);
2186       P      : constant Node_Id    := Parent_Spec (Child_Unit);
2187       P_Unit : constant Node_Id    := Unit (P);
2188
2189       P_Name : Entity_Id := Defining_Entity (P_Unit);
2190       Withn  : Node_Id;
2191
2192       function Build_Ancestor_Name (P : Node_Id)  return Node_Id;
2193       --  Build prefix of child unit name. Recurse if needed.
2194
2195       function Build_Unit_Name return Node_Id;
2196       --  If the unit is a child unit, build qualified name with all
2197       --  ancestors.
2198
2199       -------------------------
2200       -- Build_Ancestor_Name --
2201       -------------------------
2202
2203       function Build_Ancestor_Name (P : Node_Id) return Node_Id is
2204          P_Ref : Node_Id := New_Reference_To (Defining_Entity (P), Loc);
2205
2206       begin
2207          if No (Parent_Spec (P)) then
2208             return P_Ref;
2209          else
2210             return
2211               Make_Selected_Component (Loc,
2212                 Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P))),
2213                 Selector_Name => P_Ref);
2214          end if;
2215       end Build_Ancestor_Name;
2216
2217       ---------------------
2218       -- Build_Unit_Name --
2219       ---------------------
2220
2221       function Build_Unit_Name return Node_Id is
2222          Result : Node_Id;
2223
2224       begin
2225          if No (Parent_Spec (P_Unit)) then
2226             return New_Reference_To (P_Name, Loc);
2227          else
2228             Result :=
2229               Make_Expanded_Name (Loc,
2230                 Chars  => Chars (P_Name),
2231                 Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
2232                 Selector_Name => New_Reference_To (P_Name, Loc));
2233             Set_Entity (Result, P_Name);
2234             return Result;
2235          end if;
2236       end Build_Unit_Name;
2237
2238    --  Start of processing for Implicit_With_On_Parent
2239
2240    begin
2241       New_Nodes_OK := New_Nodes_OK + 1;
2242       Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
2243
2244       Set_Library_Unit          (Withn, P);
2245       Set_Corresponding_Spec    (Withn, P_Name);
2246       Set_First_Name            (Withn, True);
2247       Set_Implicit_With         (Withn, True);
2248
2249       --  Node is placed at the beginning of the context items, so that
2250       --  subsequent use clauses on the parent can be validated.
2251
2252       Prepend (Withn, Context_Items (N));
2253       Mark_Rewrite_Insertion (Withn);
2254       Install_Withed_Unit (Withn);
2255
2256       if Is_Child_Spec (P_Unit) then
2257          Implicit_With_On_Parent (P_Unit, N);
2258       end if;
2259       New_Nodes_OK := New_Nodes_OK - 1;
2260    end Implicit_With_On_Parent;
2261
2262    ---------------------
2263    -- Install_Context --
2264    ---------------------
2265
2266    procedure Install_Context (N : Node_Id) is
2267       Lib_Unit : Node_Id := Unit (N);
2268
2269    begin
2270       Install_Context_Clauses (N);
2271
2272       if Is_Child_Spec (Lib_Unit) then
2273          Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
2274       end if;
2275
2276       Check_With_Type_Clauses (N);
2277    end Install_Context;
2278
2279    -----------------------------
2280    -- Install_Context_Clauses --
2281    -----------------------------
2282
2283    procedure Install_Context_Clauses (N : Node_Id) is
2284       Lib_Unit      : Node_Id := Unit (N);
2285       Item          : Node_Id;
2286       Uname_Node    : Entity_Id;
2287       Check_Private : Boolean := False;
2288       Decl_Node     : Node_Id;
2289       Lib_Parent    : Entity_Id;
2290
2291    begin
2292       --  Loop through context clauses to find the with/use clauses
2293
2294       Item := First (Context_Items (N));
2295       while Present (Item) loop
2296
2297          --  Case of explicit WITH clause
2298
2299          if Nkind (Item) = N_With_Clause
2300            and then not Implicit_With (Item)
2301          then
2302             --  If Name (Item) is not an entity name, something is wrong, and
2303             --  this will be detected in due course, for now ignore the item
2304
2305             if not Is_Entity_Name (Name (Item)) then
2306                goto Continue;
2307             end if;
2308
2309             Uname_Node := Entity (Name (Item));
2310
2311             if Is_Private_Descendant (Uname_Node) then
2312                Check_Private := True;
2313             end if;
2314
2315             Install_Withed_Unit (Item);
2316
2317             Decl_Node := Unit_Declaration_Node (Uname_Node);
2318
2319             --  If the unit is a subprogram instance, it appears nested
2320             --  within a package that carries the parent information.
2321
2322             if Is_Generic_Instance (Uname_Node)
2323               and then Ekind (Uname_Node) /= E_Package
2324             then
2325                Decl_Node := Parent (Parent (Decl_Node));
2326             end if;
2327
2328             if Is_Child_Spec (Decl_Node) then
2329                if Nkind (Name (Item)) = N_Expanded_Name then
2330                   Expand_With_Clause (Prefix (Name (Item)), N);
2331                else
2332                   --  if not an expanded name, the child unit must be a
2333                   --  renaming, nothing to do.
2334
2335                   null;
2336                end if;
2337
2338             elsif Nkind (Decl_Node) = N_Subprogram_Body
2339               and then not Acts_As_Spec (Parent (Decl_Node))
2340               and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node))))
2341             then
2342                Implicit_With_On_Parent
2343                  (Unit (Library_Unit (Parent (Decl_Node))), N);
2344             end if;
2345
2346             --  Check license conditions unless this is a dummy unit
2347
2348             if Sloc (Library_Unit (Item)) /= No_Location then
2349                License_Check : declare
2350                   Withl : constant License_Type :=
2351                             License (Source_Index
2352                                        (Get_Source_Unit
2353                                          (Library_Unit (Item))));
2354
2355                   Unitl : constant License_Type :=
2356                            License (Source_Index (Current_Sem_Unit));
2357
2358                   procedure License_Error;
2359                   --  Signal error of bad license
2360
2361                   -------------------
2362                   -- License_Error --
2363                   -------------------
2364
2365                   procedure License_Error is
2366                   begin
2367                      Error_Msg_N
2368                        ("?license of with'ed unit & is incompatible",
2369                         Name (Item));
2370                   end License_Error;
2371
2372                --  Start of processing for License_Check
2373
2374                begin
2375                   case Unitl is
2376                      when Unknown =>
2377                         null;
2378
2379                      when Restricted =>
2380                         if Withl = GPL then
2381                            License_Error;
2382                         end if;
2383
2384                      when GPL =>
2385                         if Withl = Restricted then
2386                            License_Error;
2387                         end if;
2388
2389                      when Modified_GPL =>
2390                         if Withl = Restricted or else Withl = GPL then
2391                            License_Error;
2392                         end if;
2393
2394                      when Unrestricted =>
2395                         null;
2396                   end case;
2397                end License_Check;
2398             end if;
2399
2400          --  Case of USE PACKAGE clause
2401
2402          elsif Nkind (Item) = N_Use_Package_Clause then
2403             Analyze_Use_Package (Item);
2404
2405          --  Case of USE TYPE clause
2406
2407          elsif Nkind (Item) = N_Use_Type_Clause then
2408             Analyze_Use_Type (Item);
2409
2410          --  Case of WITH TYPE clause
2411
2412          --  A With_Type_Clause is processed when installing the context,
2413          --  because it is a visibility mechanism and does not create a
2414          --  semantic dependence on other units, as a With_Clause does.
2415
2416          elsif Nkind (Item) = N_With_Type_Clause then
2417             Analyze_With_Type_Clause (Item);
2418
2419          --  case of PRAGMA
2420
2421          elsif Nkind (Item) = N_Pragma then
2422             Analyze (Item);
2423          end if;
2424
2425       <<Continue>>
2426          Next (Item);
2427       end loop;
2428
2429       if Is_Child_Spec (Lib_Unit) then
2430
2431          --  The unit also has implicit withs on its own parents.
2432
2433          if No (Context_Items (N)) then
2434             Set_Context_Items (N, New_List);
2435          end if;
2436
2437          Implicit_With_On_Parent (Lib_Unit, N);
2438       end if;
2439
2440       --  If the unit is a body, the context of the specification must also
2441       --  be installed.
2442
2443       if Nkind (Lib_Unit) = N_Package_Body
2444         or else (Nkind (Lib_Unit) = N_Subprogram_Body
2445                   and then not Acts_As_Spec (N))
2446       then
2447          Install_Context (Library_Unit (N));
2448
2449          if Is_Child_Spec (Unit (Library_Unit (N))) then
2450
2451             --  If the unit is the body of a public child unit, the private
2452             --  declarations of the parent must be made visible. If the child
2453             --  unit is private, the private declarations have been installed
2454             --  already in the call to Install_Parents for the spec. Installing
2455             --  private declarations must be done for all ancestors of public
2456             --  child units. In addition, sibling units mentioned in the
2457             --  context clause of the body are directly visible.
2458
2459             declare
2460                Lib_Spec : Node_Id := Unit (Library_Unit (N));
2461                P        : Node_Id;
2462                P_Name   : Entity_Id;
2463
2464             begin
2465                while Is_Child_Spec (Lib_Spec) loop
2466                   P := Unit (Parent_Spec (Lib_Spec));
2467
2468                   if not (Private_Present (Parent (Lib_Spec))) then
2469                      P_Name := Defining_Entity (P);
2470                      Install_Private_Declarations (P_Name);
2471                      Set_Use (Private_Declarations (Specification (P)));
2472                   end if;
2473
2474                   Lib_Spec := P;
2475                end loop;
2476             end;
2477          end if;
2478
2479          --  For a package body, children in context are immediately visible
2480
2481          Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
2482       end if;
2483
2484       if Nkind (Lib_Unit) = N_Generic_Package_Declaration
2485         or else Nkind (Lib_Unit) = N_Generic_Subprogram_Declaration
2486         or else Nkind (Lib_Unit) = N_Package_Declaration
2487         or else Nkind (Lib_Unit) = N_Subprogram_Declaration
2488       then
2489          if Is_Child_Spec (Lib_Unit) then
2490             Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
2491             Set_Is_Private_Descendant
2492               (Defining_Entity (Lib_Unit),
2493                Is_Private_Descendant (Lib_Parent)
2494                  or else Private_Present (Parent (Lib_Unit)));
2495
2496          else
2497             Set_Is_Private_Descendant
2498               (Defining_Entity (Lib_Unit),
2499                Private_Present (Parent (Lib_Unit)));
2500          end if;
2501       end if;
2502
2503       if Check_Private then
2504          Check_Private_Child_Unit (N);
2505       end if;
2506    end Install_Context_Clauses;
2507
2508    ---------------------
2509    -- Install_Parents --
2510    ---------------------
2511
2512    procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
2513       P      : Node_Id;
2514       E_Name : Entity_Id;
2515       P_Name : Entity_Id;
2516       P_Spec : Node_Id;
2517
2518    begin
2519       P := Unit (Parent_Spec (Lib_Unit));
2520       P_Name := Defining_Entity (P);
2521
2522       if Etype (P_Name) = Any_Type then
2523          return;
2524       end if;
2525
2526       if Ekind (P_Name) = E_Generic_Package
2527         and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
2528         and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
2529         and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
2530       then
2531          Error_Msg_N
2532            ("child of a generic package must be a generic unit", Lib_Unit);
2533
2534       elsif not Is_Package (P_Name) then
2535          Error_Msg_N
2536            ("parent unit must be package or generic package", Lib_Unit);
2537          raise Unrecoverable_Error;
2538
2539       elsif Present (Renamed_Object (P_Name)) then
2540          Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
2541          raise Unrecoverable_Error;
2542
2543       --  Verify that a child of an instance is itself an instance, or
2544       --  the renaming of one. Given that an instance that is a unit is
2545       --  replaced with a package declaration, check against the original
2546       --  node.
2547
2548       elsif Nkind (Original_Node (P)) = N_Package_Instantiation
2549         and then Nkind (Lib_Unit)
2550                    not in N_Renaming_Declaration
2551         and then Nkind (Original_Node (Lib_Unit))
2552                    not in N_Generic_Instantiation
2553       then
2554          Error_Msg_N
2555            ("child of an instance must be an instance or renaming", Lib_Unit);
2556       end if;
2557
2558       --  This is the recursive call that ensures all parents are loaded
2559
2560       if Is_Child_Spec (P) then
2561          Install_Parents (P,
2562            Is_Private or else Private_Present (Parent (Lib_Unit)));
2563       end if;
2564
2565       --  Now we can install the context for this parent
2566
2567       Install_Context_Clauses (Parent_Spec (Lib_Unit));
2568       Install_Siblings (P_Name, Parent (Lib_Unit));
2569
2570       --  The child unit is in the declarative region of the parent. The
2571       --  parent must therefore appear in the scope stack and be visible,
2572       --  as when compiling the corresponding body. If the child unit is
2573       --  private or it is a package body, private declarations must be
2574       --  accessible as well. Use declarations in the parent must also
2575       --  be installed. Finally, other child units of the same parent that
2576       --  are in the context are immediately visible.
2577
2578       --  Find entity for compilation unit, and set its private descendant
2579       --  status as needed.
2580
2581       E_Name := Defining_Entity (Lib_Unit);
2582
2583       Set_Is_Child_Unit (E_Name);
2584
2585       Set_Is_Private_Descendant (E_Name,
2586          Is_Private_Descendant (P_Name)
2587            or else Private_Present (Parent (Lib_Unit)));
2588
2589       P_Spec := Specification (Unit_Declaration_Node (P_Name));
2590       New_Scope (P_Name);
2591
2592       --  Save current visibility of unit
2593
2594       Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
2595         Is_Immediately_Visible (P_Name);
2596       Set_Is_Immediately_Visible (P_Name);
2597       Install_Visible_Declarations (P_Name);
2598       Set_Use (Visible_Declarations (P_Spec));
2599
2600       if Is_Private
2601         or else Private_Present (Parent (Lib_Unit))
2602       then
2603          Install_Private_Declarations (P_Name);
2604          Set_Use (Private_Declarations (P_Spec));
2605       end if;
2606    end Install_Parents;
2607
2608    ----------------------
2609    -- Install_Siblings --
2610    ----------------------
2611
2612    procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
2613       Item : Node_Id;
2614       Id   : Entity_Id;
2615       Prev : Entity_Id;
2616
2617       function Is_Ancestor (E : Entity_Id) return Boolean;
2618       --  Determine whether the scope of a child unit is an ancestor of
2619       --  the current unit.
2620       --  Shouldn't this be somewhere more general ???
2621
2622       function Is_Ancestor (E : Entity_Id) return Boolean is
2623          Par : Entity_Id;
2624
2625       begin
2626          Par := U_Name;
2627
2628          while Present (Par)
2629            and then Par /= Standard_Standard
2630          loop
2631
2632             if Par = E then
2633                return True;
2634             end if;
2635
2636             Par := Scope (Par);
2637          end loop;
2638
2639          return False;
2640       end Is_Ancestor;
2641
2642    --  Start of processing for Install_Siblings
2643
2644    begin
2645       --  Iterate over explicit with clauses, and check whether the
2646       --  scope of each entity is an ancestor of the current unit.
2647
2648       Item := First (Context_Items (N));
2649
2650       while Present (Item) loop
2651
2652          if Nkind (Item) = N_With_Clause
2653            and then not Implicit_With (Item)
2654          then
2655             Id := Entity (Name (Item));
2656
2657             if Is_Child_Unit (Id)
2658               and then Is_Ancestor (Scope (Id))
2659             then
2660                Set_Is_Immediately_Visible (Id);
2661                Prev := Current_Entity (Id);
2662
2663                --  Check for the presence of another unit in the context,
2664                --  that may be inadvertently hidden by the child.
2665
2666                if Present (Prev)
2667                  and then Is_Immediately_Visible (Prev)
2668                  and then not Is_Child_Unit (Prev)
2669                then
2670                   declare
2671                      Clause : Node_Id;
2672
2673                   begin
2674                      Clause := First (Context_Items (N));
2675
2676                      while Present (Clause) loop
2677                         if Nkind (Clause) = N_With_Clause
2678                           and then Entity (Name (Clause)) = Prev
2679                         then
2680                            Error_Msg_NE
2681                               ("child unit& hides compilation unit " &
2682                                "with the same name?",
2683                                  Name (Item), Id);
2684                            exit;
2685                         end if;
2686
2687                         Next (Clause);
2688                      end loop;
2689                   end;
2690                end if;
2691
2692             --  the With_Clause may be on a grand-child, which makes
2693             --  the child immediately visible.
2694
2695             elsif Is_Child_Unit (Scope (Id))
2696               and then Is_Ancestor (Scope (Scope (Id)))
2697             then
2698                Set_Is_Immediately_Visible (Scope (Id));
2699             end if;
2700          end if;
2701
2702          Next (Item);
2703       end loop;
2704    end Install_Siblings;
2705
2706    -------------------------
2707    -- Install_Withed_Unit --
2708    -------------------------
2709
2710    procedure Install_Withed_Unit (With_Clause : Node_Id) is
2711       Uname : Entity_Id := Entity (Name (With_Clause));
2712       P     : constant Entity_Id := Scope (Uname);
2713
2714    begin
2715       --  If the unit is a package instantiation, its body may have been
2716       --  generated for an inner instance, and the instance now denotes the
2717       --  body entity. For visibility purposes we need the instance in the
2718       --  specification.
2719
2720       if Ekind (Uname) = E_Package_Body
2721         and then Is_Generic_Instance (Uname)
2722       then
2723          Uname := Spec_Entity (Uname);
2724       end if;
2725
2726       --  We do not apply the restrictions to an internal unit unless
2727       --  we are compiling the internal unit as a main unit. This check
2728       --  is also skipped for dummy units (for missing packages).
2729
2730       if Sloc (Uname) /= No_Location
2731         and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
2732                     or else Current_Sem_Unit = Main_Unit)
2733       then
2734          Check_Restricted_Unit
2735            (Unit_Name (Get_Source_Unit (Uname)), With_Clause);
2736       end if;
2737
2738       if P /= Standard_Standard then
2739
2740          --  If the unit is not analyzed after analysis of the with clause,
2741          --  and it is an instantiation, then it awaits a body and is the main
2742          --  unit. Its appearance in the context of some other unit indicates
2743          --  a circular dependency (DEC suite perversity).
2744
2745          if not Analyzed (Uname)
2746            and then Nkind (Parent (Uname)) = N_Package_Instantiation
2747          then
2748             Error_Msg_N
2749               ("instantiation depends on itself", Name (With_Clause));
2750
2751          elsif not Is_Visible_Child_Unit (Uname) then
2752             Set_Is_Visible_Child_Unit (Uname);
2753
2754             if Is_Generic_Instance (Uname)
2755               and then Ekind (Uname) in Subprogram_Kind
2756             then
2757                --  Set flag as well on the visible entity that denotes the
2758                --  instance, which renames the current one.
2759
2760                Set_Is_Visible_Child_Unit
2761                  (Related_Instance
2762                    (Defining_Entity (Unit (Library_Unit (With_Clause)))));
2763                null;
2764             end if;
2765
2766             --  The parent unit may have been installed already, and
2767             --  may have appeared in a use clause.
2768
2769             if In_Use (Scope (Uname)) then
2770                Set_Is_Potentially_Use_Visible (Uname);
2771             end if;
2772
2773             Set_Context_Installed (With_Clause);
2774          end if;
2775
2776       elsif not Is_Immediately_Visible (Uname) then
2777          Set_Is_Immediately_Visible (Uname);
2778          Set_Context_Installed (With_Clause);
2779       end if;
2780
2781       --   A with-clause overrides a with-type clause: there are no restric-
2782       --   tions on the use of package entities.
2783
2784       if Ekind (Uname) = E_Package then
2785          Set_From_With_Type (Uname, False);
2786       end if;
2787    end Install_Withed_Unit;
2788
2789    -------------------
2790    -- Is_Child_Spec --
2791    -------------------
2792
2793    function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is
2794       K : constant Node_Kind := Nkind (Lib_Unit);
2795
2796    begin
2797       return (K in N_Generic_Declaration              or else
2798               K in N_Generic_Instantiation            or else
2799               K in N_Generic_Renaming_Declaration     or else
2800               K =  N_Package_Declaration              or else
2801               K =  N_Package_Renaming_Declaration     or else
2802               K =  N_Subprogram_Declaration           or else
2803               K =  N_Subprogram_Renaming_Declaration)
2804         and then Present (Parent_Spec (Lib_Unit));
2805    end Is_Child_Spec;
2806
2807    -----------------------
2808    -- Load_Needed_Body --
2809    -----------------------
2810
2811    --  N is a generic unit named in a with clause, or else it is
2812    --  a unit that contains a generic unit or an inlined function.
2813    --  In order to perform an instantiation, the body of the unit
2814    --  must be present. If the unit itself is generic, we assume
2815    --  that an instantiation follows, and  load and analyze the body
2816    --  unconditionally. This forces analysis of the spec as well.
2817
2818    --  If the unit is not generic, but contains a generic unit, it
2819    --  is loaded on demand, at the point of instantiation (see ch12).
2820
2821    procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
2822       Body_Name : Unit_Name_Type;
2823       Unum      : Unit_Number_Type;
2824
2825       Save_Style_Check : constant Boolean := Opt.Style_Check;
2826       --  The loading and analysis is done with style checks off
2827
2828    begin
2829       if not GNAT_Mode then
2830          Style_Check := False;
2831       end if;
2832
2833       Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N)));
2834       Unum :=
2835         Load_Unit
2836           (Load_Name  => Body_Name,
2837            Required   => False,
2838            Subunit    => False,
2839            Error_Node => N,
2840            Renamings  => True);
2841
2842       if Unum = No_Unit then
2843          OK := False;
2844
2845       else
2846          Compiler_State := Analyzing; -- reset after load
2847
2848          if not Fatal_Error (Unum) then
2849             if Debug_Flag_L then
2850                Write_Str ("*** Loaded generic body");
2851                Write_Eol;
2852             end if;
2853
2854             Semantics (Cunit (Unum));
2855          end if;
2856
2857          OK := True;
2858       end if;
2859
2860       Style_Check := Save_Style_Check;
2861    end Load_Needed_Body;
2862
2863    --------------------
2864    -- Remove_Context --
2865    --------------------
2866
2867    procedure Remove_Context (N : Node_Id) is
2868       Lib_Unit : constant Node_Id := Unit (N);
2869
2870    begin
2871       --  If this is a child unit, first remove the parent units.
2872
2873       if Is_Child_Spec (Lib_Unit) then
2874          Remove_Parents (Lib_Unit);
2875       end if;
2876
2877       Remove_Context_Clauses (N);
2878    end Remove_Context;
2879
2880    ----------------------------
2881    -- Remove_Context_Clauses --
2882    ----------------------------
2883
2884    procedure Remove_Context_Clauses (N : Node_Id) is
2885       Item      : Node_Id;
2886       Unit_Name : Entity_Id;
2887
2888    begin
2889
2890       --  Loop through context items and undo with_clauses and use_clauses.
2891
2892       Item := First (Context_Items (N));
2893
2894       while Present (Item) loop
2895
2896          --  We are interested only in with clauses which got installed
2897          --  on entry, as indicated by their Context_Installed flag set
2898
2899          if Nkind (Item) = N_With_Clause
2900             and then Context_Installed (Item)
2901          then
2902             --  Remove items from one with'ed unit
2903
2904             Unit_Name := Entity (Name (Item));
2905             Remove_Unit_From_Visibility (Unit_Name);
2906             Set_Context_Installed (Item, False);
2907
2908          elsif Nkind (Item) = N_Use_Package_Clause then
2909             End_Use_Package (Item);
2910
2911          elsif Nkind (Item) = N_Use_Type_Clause then
2912             End_Use_Type (Item);
2913
2914          elsif Nkind (Item) = N_With_Type_Clause then
2915             Remove_With_Type_Clause (Name (Item));
2916          end if;
2917
2918          Next (Item);
2919       end loop;
2920
2921    end Remove_Context_Clauses;
2922
2923    --------------------
2924    -- Remove_Parents --
2925    --------------------
2926
2927    procedure Remove_Parents (Lib_Unit : Node_Id) is
2928       P      : Node_Id;
2929       P_Name : Entity_Id;
2930       E      : Entity_Id;
2931       Vis    : constant Boolean :=
2932                  Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
2933
2934    begin
2935       if Is_Child_Spec (Lib_Unit) then
2936          P := Unit (Parent_Spec (Lib_Unit));
2937          P_Name := Defining_Entity (P);
2938
2939          Remove_Context_Clauses (Parent_Spec (Lib_Unit));
2940          End_Package_Scope (P_Name);
2941          Set_Is_Immediately_Visible (P_Name, Vis);
2942
2943          --  Remove from visibility the siblings as well, which are directly
2944          --  visible while the parent is in scope.
2945
2946          E := First_Entity (P_Name);
2947
2948          while Present (E) loop
2949
2950             if Is_Child_Unit (E) then
2951                Set_Is_Immediately_Visible (E, False);
2952             end if;
2953
2954             Next_Entity (E);
2955          end loop;
2956
2957          Set_In_Package_Body (P_Name, False);
2958
2959          --  This is the recursive call to remove the context of any
2960          --  higher level parent. This recursion ensures that all parents
2961          --  are removed in the reverse order of their installation.
2962
2963          Remove_Parents (P);
2964       end if;
2965    end Remove_Parents;
2966
2967    -----------------------------
2968    -- Remove_With_Type_Clause --
2969    -----------------------------
2970
2971    procedure Remove_With_Type_Clause (Name : Node_Id) is
2972       Typ : Entity_Id;
2973       P   : Entity_Id;
2974
2975       procedure Unchain (E : Entity_Id);
2976       --  Remove entity from visibility list.
2977
2978       procedure Unchain (E : Entity_Id) is
2979          Prev : Entity_Id;
2980
2981       begin
2982          Prev := Current_Entity (E);
2983
2984          --  Package entity may appear is several with_type_clauses, and
2985          --  may have been removed already.
2986
2987          if No (Prev) then
2988             return;
2989
2990          elsif Prev = E then
2991             Set_Name_Entity_Id (Chars (E), Homonym (E));
2992
2993          else
2994             while Present (Prev)
2995               and then Homonym (Prev) /= E
2996             loop
2997                Prev := Homonym (Prev);
2998             end loop;
2999
3000             if (Present (Prev)) then
3001                Set_Homonym (Prev, Homonym (E));
3002             end if;
3003          end if;
3004       end Unchain;
3005
3006    begin
3007       if Nkind (Name) = N_Selected_Component then
3008          Typ := Entity (Selector_Name (Name));
3009
3010          if No (Typ) then    --  error in declaration.
3011             return;
3012          end if;
3013       else
3014          return;
3015       end if;
3016
3017       P := Scope (Typ);
3018
3019       --  If the exporting package has been analyzed, it has appeared in the
3020       --  context already and should be left alone. Otherwise, remove from
3021       --  visibility.
3022
3023       if not Analyzed (Unit_Declaration_Node (P)) then
3024          Unchain (P);
3025          Unchain (Typ);
3026          Set_Is_Frozen (Typ, False);
3027       end if;
3028
3029       if Ekind (Typ) = E_Record_Type then
3030          Set_From_With_Type (Class_Wide_Type (Typ), False);
3031          Set_From_With_Type (Typ, False);
3032       end if;
3033
3034       Set_From_With_Type (P, False);
3035
3036       --  If P is a child unit, remove parents as well.
3037
3038       P := Scope (P);
3039
3040       while Present (P)
3041         and then P /= Standard_Standard
3042       loop
3043          Set_From_With_Type (P, False);
3044
3045          if not Analyzed (Unit_Declaration_Node (P)) then
3046             Unchain (P);
3047          end if;
3048
3049          P := Scope (P);
3050       end loop;
3051
3052       --  The back-end needs to know that an access type is imported, so it
3053       --  does not need elaboration and can appear in a mutually recursive
3054       --  record definition, so the imported flag on an access  type is
3055       --  preserved.
3056
3057    end Remove_With_Type_Clause;
3058
3059    ---------------------------------
3060    -- Remove_Unit_From_Visibility --
3061    ---------------------------------
3062
3063    procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
3064       P : Entity_Id := Scope (Unit_Name);
3065
3066    begin
3067
3068       if Debug_Flag_I then
3069          Write_Str ("remove withed unit ");
3070          Write_Name (Chars (Unit_Name));
3071          Write_Eol;
3072       end if;
3073
3074       if P /= Standard_Standard then
3075          Set_Is_Visible_Child_Unit (Unit_Name, False);
3076       end if;
3077
3078       Set_Is_Potentially_Use_Visible (Unit_Name, False);
3079       Set_Is_Immediately_Visible     (Unit_Name, False);
3080
3081    end Remove_Unit_From_Visibility;
3082
3083 end Sem_Ch10;