gcc/ada/sem_ch10.adb

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