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