gcc/ada/sem_ch7.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M . C H 7                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2006, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 --  This package contains the routines to process package specifications and
  28 --  bodies. The most important semantic aspects of package processing are the
  29 --  handling of private and full declarations, and the construction of
  30 --  dispatch tables for tagged types.
  31
  32 with Atree;    use Atree;
  33 with Debug;    use Debug;
  34 with Einfo;    use Einfo;
  35 with Elists;   use Elists;
  36 with Errout;   use Errout;
  37 with Exp_Disp; use Exp_Disp;
  38 with Exp_Dist; use Exp_Dist;
  39 with Exp_Dbug; use Exp_Dbug;
  40 with Lib;      use Lib;
  41 with Lib.Xref; use Lib.Xref;
  42 with Namet;    use Namet;
  43 with Nmake;    use Nmake;
  44 with Nlists;   use Nlists;
  45 with Opt;      use Opt;
  46 with Output;   use Output;
  47 with Sem;      use Sem;
  48 with Sem_Cat;  use Sem_Cat;
  49 with Sem_Ch3;  use Sem_Ch3;
  50 with Sem_Ch6;  use Sem_Ch6;
  51 with Sem_Ch8;  use Sem_Ch8;
  52 with Sem_Ch10; use Sem_Ch10;
  53 with Sem_Ch12; use Sem_Ch12;
  54 with Sem_Disp; use Sem_Disp;
  55 with Sem_Util; use Sem_Util;
  56 with Sem_Warn; use Sem_Warn;
  57 with Snames;   use Snames;
  58 with Stand;    use Stand;
  59 with Sinfo;    use Sinfo;
  60 with Sinput;   use Sinput;
  61 with Style;
  62
  63 package body Sem_Ch7 is
  64
  65    -----------------------------------
  66    -- Handling private declarations --
  67    -----------------------------------
  68
  69    --  The principle that each entity has a single defining occurrence clashes
  70    --  with the presence of two separate definitions for private types: the
  71    --  first is the private type declaration, and the second is the full type
  72    --  declaration. It is important that all references to the type point to
  73    --  the same defining occurrence, namely the first one. To enforce the two
  74    --  separate views of the entity, the corresponding information is swapped
  75    --  between the two declarations. Outside of the package, the defining
  76    --  occurrence only contains the private declaration information, while in
  77    --  the private part and the body of the package the defining occurrence
  78    --  contains the full declaration. To simplify the swap, the defining
  79    --  occurrence that currently holds the private declaration points to the
  80    --  full declaration. During semantic processing the defining occurrence
  81    --  also points to a list of private dependents, that is to say access types
  82    --  or composite types whose designated types or component types are
  83    --  subtypes or derived types of the private type in question. After the
  84    --  full declaration has been seen, the private dependents are updated to
  85    --  indicate that they have full definitions.
  86
  87    -----------------------
  88    -- Local Subprograms --
  89    -----------------------
  90
  91    procedure Check_Anonymous_Access_Types
  92      (Spec_Id : Entity_Id;
  93       P_Body  : Node_Id);
  94    --  If the spec of a package has a limited_with_clause, it may declare
  95    --  anonymous access types whose designated type is a limited view, such an
  96    --  anonymous access return type for a function. This access type cannot be
  97    --  elaborated in the spec itself, but it may need an itype reference if it
  98    --  is used within a nested scope. In that case the itype reference is
  99    --  created at the beginning of the corresponding package body and inserted
 100    --  before other body declarations.
 101
 102    procedure Inspect_Deferred_Constant_Completion (Decls : List_Id);
 103    --  Examines the deferred constants in the private part of the package
 104    --  specification, or in a package body. Emits the error message
 105    --  "constant declaration requires initialization expression" if not
 106    --  completed by an Import pragma.
 107
 108    procedure Install_Package_Entity (Id : Entity_Id);
 109    --  Supporting procedure for Install_{Visible,Private}_Declarations.
 110    --  Places one entity on its visibility chain, and recurses on the visible
 111    --  part if the entity is an inner package.
 112
 113    function Is_Private_Base_Type (E : Entity_Id) return Boolean;
 114    --  True for a private type that is not a subtype
 115
 116    function Is_Visible_Dependent (Dep : Entity_Id) return Boolean;
 117    --  If the private dependent is a private type whose full view is derived
 118    --  from the parent type, its full properties are revealed only if we are in
 119    --  the immediate scope of the private dependent. Should this predicate be
 120    --  tightened further???
 121
 122    procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id);
 123    --  Called upon entering the private part of a public child package and the
 124    --  body of a nested package, to potentially declare certain inherited
 125    --  subprograms that were inherited by types in the visible part, but whose
 126    --  declaration was deferred because the parent operation was private and
 127    --  not visible at that point. These subprograms are located by traversing
 128    --  the visible part declarations looking for non-private type extensions
 129    --  and then examining each of the primitive operations of such types to
 130    --  find those that were inherited but declared with a special internal
 131    --  name. Each such operation is now declared as an operation with a normal
 132    --  name (using the name of the parent operation) and replaces the previous
 133    --  implicit operation in the primitive operations list of the type. If the
 134    --  inherited private operation has been overridden, then it's replaced by
 135    --  the overriding operation.
 136
 137    --------------------------
 138    -- Analyze_Package_Body --
 139    --------------------------
 140
 141    procedure Analyze_Package_Body (N : Node_Id) is
 142       Loc              : constant Source_Ptr := Sloc (N);
 143       HSS              : Node_Id;
 144       Body_Id          : Entity_Id;
 145       Spec_Id          : Entity_Id;
 146       Last_Spec_Entity : Entity_Id;
 147       New_N            : Node_Id;
 148       Pack_Decl        : Node_Id;
 149
 150       procedure Install_Composite_Operations (P : Entity_Id);
 151       --  Composite types declared in the current scope may depend on
 152       --  types that were private at the point of declaration, and whose
 153       --  full view is now in  scope. Indicate that the corresponding
 154       --  operations on the composite type are available.
 155
 156       ----------------------------------
 157       -- Install_Composite_Operations --
 158       ----------------------------------
 159
 160       procedure Install_Composite_Operations (P : Entity_Id) is
 161          Id : Entity_Id;
 162
 163       begin
 164          Id := First_Entity (P);
 165          while Present (Id) loop
 166             if Is_Type (Id)
 167               and then (Is_Limited_Composite (Id)
 168                          or else Is_Private_Composite (Id))
 169               and then No (Private_Component (Id))
 170             then
 171                Set_Is_Limited_Composite (Id, False);
 172                Set_Is_Private_Composite (Id, False);
 173             end if;
 174
 175             Next_Entity (Id);
 176          end loop;
 177       end Install_Composite_Operations;
 178
 179    --  Start of processing for Analyze_Package_Body
 180
 181    begin
 182       --  Find corresponding package specification, and establish the
 183       --  current scope. The visible defining entity for the package is the
 184       --  defining occurrence in the spec. On exit from the package body, all
 185       --  body declarations are attached to the defining entity for the body,
 186       --  but the later is never used for name resolution. In this fashion
 187       --  there is only one visible entity that denotes the package.
 188
 189       if Debug_Flag_C then
 190          Write_Str ("====  Compiling package body ");
 191          Write_Name (Chars (Defining_Entity (N)));
 192          Write_Str (" from ");
 193          Write_Location (Loc);
 194          Write_Eol;
 195       end if;
 196
 197       --  Set Body_Id. Note that this Will be reset to point to the
 198       --  generic copy later on in the generic case.
 199
 200       Body_Id := Defining_Entity (N);
 201
 202       if Present (Corresponding_Spec (N)) then
 203
 204          --  Body is body of package instantiation. Corresponding spec
 205          --  has already been set.
 206
 207          Spec_Id := Corresponding_Spec (N);
 208          Pack_Decl := Unit_Declaration_Node (Spec_Id);
 209
 210       else
 211          Spec_Id := Current_Entity_In_Scope (Defining_Entity (N));
 212
 213          if Present (Spec_Id)
 214            and then Is_Package_Or_Generic_Package (Spec_Id)
 215          then
 216             Pack_Decl := Unit_Declaration_Node (Spec_Id);
 217
 218             if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then
 219                Error_Msg_N ("cannot supply body for package renaming", N);
 220                return;
 221
 222             elsif Present (Corresponding_Body (Pack_Decl)) then
 223                Error_Msg_N ("redefinition of package body", N);
 224                return;
 225             end if;
 226
 227          else
 228             Error_Msg_N ("missing specification for package body", N);
 229             return;
 230          end if;
 231
 232          if Is_Package_Or_Generic_Package (Spec_Id)
 233            and then
 234              (Scope (Spec_Id) = Standard_Standard
 235                or else Is_Child_Unit (Spec_Id))
 236            and then not Unit_Requires_Body (Spec_Id)
 237          then
 238             if Ada_Version = Ada_83 then
 239                Error_Msg_N
 240                  ("optional package body (not allowed in Ada 95)?", N);
 241             else
 242                Error_Msg_N
 243                  ("spec of this package does not allow a body", N);
 244             end if;
 245          end if;
 246       end if;
 247
 248       Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
 249       Style.Check_Identifier (Body_Id, Spec_Id);
 250
 251       if Is_Child_Unit (Spec_Id) then
 252          if Nkind (Parent (N)) /= N_Compilation_Unit then
 253             Error_Msg_NE
 254               ("body of child unit& cannot be an inner package", N, Spec_Id);
 255          end if;
 256
 257          Set_Is_Child_Unit (Body_Id);
 258       end if;
 259
 260       --  Generic package case
 261
 262       if Ekind (Spec_Id) = E_Generic_Package then
 263
 264          --  Disable expansion and perform semantic analysis on copy.
 265          --  The unannotated body will be used in all instantiations.
 266
 267          Body_Id := Defining_Entity (N);
 268          Set_Ekind (Body_Id, E_Package_Body);
 269          Set_Scope (Body_Id, Scope (Spec_Id));
 270          Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
 271          Set_Body_Entity (Spec_Id, Body_Id);
 272          Set_Spec_Entity (Body_Id, Spec_Id);
 273
 274          New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
 275          Rewrite (N, New_N);
 276
 277          --  Update Body_Id to point to the copied node for the remainder
 278          --  of the processing.
 279
 280          Body_Id := Defining_Entity (N);
 281          Start_Generic;
 282       end if;
 283
 284       --  The Body_Id is that of the copied node in the generic case, the
 285       --  current node otherwise. Note that N was rewritten above, so we
 286       --  must be sure to get the latest Body_Id value.
 287
 288       Set_Ekind (Body_Id, E_Package_Body);
 289       Set_Body_Entity (Spec_Id, Body_Id);
 290       Set_Spec_Entity (Body_Id, Spec_Id);
 291
 292       --  Defining name for the package body is not a visible entity: Only
 293       --  the defining name for the declaration is visible.
 294
 295       Set_Etype (Body_Id, Standard_Void_Type);
 296       Set_Scope (Body_Id, Scope (Spec_Id));
 297       Set_Corresponding_Spec (N, Spec_Id);
 298       Set_Corresponding_Body (Pack_Decl, Body_Id);
 299
 300       --  The body entity is not used for semantics or code generation, but
 301       --  it is attached to the entity list of the enclosing scope to simplify
 302       --  the listing of back-annotations for the types it main contain.
 303
 304       if Scope (Spec_Id) /= Standard_Standard then
 305          Append_Entity (Body_Id, Scope (Spec_Id));
 306       end if;
 307
 308       --  Indicate that we are currently compiling the body of the package
 309
 310       Set_In_Package_Body (Spec_Id);
 311       Set_Has_Completion (Spec_Id);
 312       Last_Spec_Entity := Last_Entity (Spec_Id);
 313
 314       New_Scope (Spec_Id);
 315
 316       Set_Categorization_From_Pragmas (N);
 317
 318       Install_Visible_Declarations (Spec_Id);
 319       Install_Private_Declarations (Spec_Id);
 320       Install_Private_With_Clauses (Spec_Id);
 321       Install_Composite_Operations (Spec_Id);
 322
 323       Check_Anonymous_Access_Types (Spec_Id, N);
 324
 325       if Ekind (Spec_Id) = E_Generic_Package then
 326          Set_Use (Generic_Formal_Declarations (Pack_Decl));
 327       end if;
 328
 329       Set_Use (Visible_Declarations (Specification (Pack_Decl)));
 330       Set_Use (Private_Declarations (Specification (Pack_Decl)));
 331
 332       --  This is a nested package, so it may be necessary to declare certain
 333       --  inherited subprograms that are not yet visible because the parent
 334       --  type's subprograms are now visible.
 335
 336       if Ekind (Scope (Spec_Id)) = E_Package
 337         and then Scope (Spec_Id) /= Standard_Standard
 338       then
 339          Declare_Inherited_Private_Subprograms (Spec_Id);
 340       end if;
 341
 342       if Present (Declarations (N)) then
 343          Analyze_Declarations (Declarations (N));
 344          Inspect_Deferred_Constant_Completion (Declarations (N));
 345       end if;
 346
 347       --  Analyze_Declarations has caused freezing of all types; now generate
 348       --  bodies for RACW primitives and stream attributes, if any.
 349
 350       if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then
 351
 352          --  Attach subprogram bodies to support RACWs declared in spec
 353
 354          Append_RACW_Bodies (Declarations (N), Spec_Id);
 355          Analyze_List (Declarations (N));
 356       end if;
 357
 358       HSS := Handled_Statement_Sequence (N);
 359
 360       if Present (HSS) then
 361          Process_End_Label (HSS, 't', Spec_Id);
 362          Analyze (HSS);
 363
 364          --  Check that elaboration code in a preelaborable package body is
 365          --  empty other than null statements and labels (RM 10.2.1(6)).
 366
 367          Validate_Null_Statement_Sequence (N);
 368       end if;
 369
 370       Validate_Categorization_Dependency (N, Spec_Id);
 371       Check_Completion (Body_Id);
 372
 373       --  Generate start of body reference. Note that we do this fairly late,
 374       --  because the call will use In_Extended_Main_Source_Unit as a check,
 375       --  and we want to make sure that Corresponding_Stub links are set
 376
 377       Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
 378
 379       --  For a generic package, collect global references and mark them on
 380       --  the original body so that they are not resolved again at the point
 381       --  of instantiation.
 382
 383       if Ekind (Spec_Id) /= E_Package then
 384          Save_Global_References (Original_Node (N));
 385          End_Generic;
 386       end if;
 387
 388       --  The entities of the package body have so far been chained onto the
 389       --  declaration chain for the spec. That's been fine while we were in the
 390       --  body, since we wanted them to be visible, but now that we are leaving
 391       --  the package body, they are no longer visible, so we remove them from
 392       --  the entity chain of the package spec entity, and copy them to the
 393       --  entity chain of the package body entity, where they will never again
 394       --  be visible.
 395
 396       if Present (Last_Spec_Entity) then
 397          Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity));
 398          Set_Next_Entity (Last_Spec_Entity, Empty);
 399          Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
 400          Set_Last_Entity (Spec_Id, Last_Spec_Entity);
 401
 402       else
 403          Set_First_Entity (Body_Id, First_Entity (Spec_Id));
 404          Set_Last_Entity  (Body_Id, Last_Entity  (Spec_Id));
 405          Set_First_Entity (Spec_Id, Empty);
 406          Set_Last_Entity  (Spec_Id, Empty);
 407       end if;
 408
 409       End_Package_Scope (Spec_Id);
 410
 411       --  All entities declared in body are not visible
 412
 413       declare
 414          E : Entity_Id;
 415
 416       begin
 417          E := First_Entity (Body_Id);
 418          while Present (E) loop
 419             Set_Is_Immediately_Visible (E, False);
 420             Set_Is_Potentially_Use_Visible (E, False);
 421             Set_Is_Hidden (E);
 422
 423             --  Child units may appear on the entity list (for example if
 424             --  they appear in the context of a subunit) but they are not
 425             --  body entities.
 426
 427             if not Is_Child_Unit (E) then
 428                Set_Is_Package_Body_Entity (E);
 429             end if;
 430
 431             Next_Entity (E);
 432          end loop;
 433       end;
 434
 435       Check_References (Body_Id);
 436
 437       --  For a generic unit, check that the formal parameters are referenced,
 438       --  and that local variables are used, as for regular packages.
 439
 440       if Ekind (Spec_Id) = E_Generic_Package then
 441          Check_References (Spec_Id);
 442       end if;
 443
 444       --  The processing so far has made all entities of the package body
 445       --  public (i.e. externally visible to the linker). This is in general
 446       --  necessary, since inlined or generic bodies, for which code is
 447       --  generated in other units, may need to see these entities. The
 448       --  following loop runs backwards from the end of the entities of the
 449       --  package body making these entities invisible until we reach a
 450       --  referencer, i.e. a declaration that could reference a previous
 451       --  declaration, a generic body or an inlined body, or a stub (which
 452       --  may contain either of these). This is of course an approximation,
 453       --  but it is conservative and definitely correct.
 454
 455       --  We only do this at the outer (library) level non-generic packages.
 456       --  The reason is simply to cut down on the number of external symbols
 457       --  generated, so this is simply an optimization of the efficiency
 458       --  of the compilation process. It has no other effect.
 459
 460       if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
 461         and then not Is_Generic_Unit (Spec_Id)
 462         and then Present (Declarations (N))
 463       then
 464          Make_Non_Public_Where_Possible : declare
 465
 466             function Has_Referencer
 467               (L     : List_Id;
 468                Outer : Boolean)
 469                return  Boolean;
 470             --  Traverse the given list of declarations in reverse order.
 471             --  Return True as soon as a referencer is reached. Return
 472             --  False if none is found. The Outer parameter is True for
 473             --  the outer level call, and False for inner level calls for
 474             --  nested packages. If Outer is True, then any entities up
 475             --  to the point of hitting a referencer get their Is_Public
 476             --  flag cleared, so that the entities will be treated as
 477             --  static entities in the C sense, and need not have fully
 478             --  qualified names. For inner levels, we need all names to
 479             --  be fully qualified to deal with the same name appearing
 480             --  in parallel packages (right now this is tied to their
 481             --  being external).
 482
 483             --------------------
 484             -- Has_Referencer --
 485             --------------------
 486
 487             function Has_Referencer
 488               (L     : List_Id;
 489                Outer : Boolean)
 490                return  Boolean
 491             is
 492                D : Node_Id;
 493                E : Entity_Id;
 494                K : Node_Kind;
 495                S : Entity_Id;
 496
 497             begin
 498                if No (L) then
 499                   return False;
 500                end if;
 501
 502                D := Last (L);
 503                while Present (D) loop
 504                   K := Nkind (D);
 505
 506                   if K in N_Body_Stub then
 507                      return True;
 508
 509                   elsif K = N_Subprogram_Body then
 510                      if Acts_As_Spec (D) then
 511                         E := Defining_Entity (D);
 512
 513                         --  An inlined body acts as a referencer. Note also
 514                         --  that we never reset Is_Public for an inlined
 515                         --  subprogram. Gigi requires Is_Public to be set.
 516
 517                         --  Note that we test Has_Pragma_Inline here rather
 518                         --  than Is_Inlined. We are compiling this for a
 519                         --  client, and it is the client who will decide
 520                         --  if actual inlining should occur, so we need to
 521                         --  assume that the procedure could be inlined for
 522                         --  the purpose of accessing global entities.
 523
 524                         if Has_Pragma_Inline (E) then
 525                            return True;
 526                         else
 527                            Set_Is_Public (E, False);
 528                         end if;
 529
 530                      else
 531                         E := Corresponding_Spec (D);
 532
 533                         if Present (E)
 534                           and then (Is_Generic_Unit (E)
 535                                      or else Has_Pragma_Inline (E)
 536                                      or else Is_Inlined (E))
 537                         then
 538                            return True;
 539                         end if;
 540                      end if;
 541
 542                   --  Processing for package bodies
 543
 544                   elsif K = N_Package_Body
 545                     and then Present (Corresponding_Spec (D))
 546                   then
 547                      E := Corresponding_Spec (D);
 548
 549                      --  Generic package body is a referencer. It would
 550                      --  seem that we only have to consider generics that
 551                      --  can be exported, i.e. where the corresponding spec
 552                      --  is the spec of the current package, but because of
 553                      --  nested instantiations, a fully private generic
 554                      --  body may export other private body entities.
 555
 556                      if Is_Generic_Unit (E) then
 557                         return True;
 558
 559                      --  For non-generic package body, recurse into body
 560                      --  unless this is an instance, we ignore instances
 561                      --  since they cannot have references that affect
 562                      --  outer entities.
 563
 564                      elsif not Is_Generic_Instance (E) then
 565                         if Has_Referencer
 566                              (Declarations (D), Outer => False)
 567                         then
 568                            return True;
 569                         end if;
 570                      end if;
 571
 572                   --  Processing for package specs, recurse into declarations.
 573                   --  Again we skip this for the case of generic instances.
 574
 575                   elsif K = N_Package_Declaration then
 576                      S := Specification (D);
 577
 578                      if not Is_Generic_Unit (Defining_Entity (S)) then
 579                         if Has_Referencer
 580                              (Private_Declarations (S), Outer => False)
 581                         then
 582                            return True;
 583                         elsif Has_Referencer
 584                                (Visible_Declarations (S), Outer => False)
 585                         then
 586                            return True;
 587                         end if;
 588                      end if;
 589
 590                   --  Objects and exceptions need not be public if we have
 591                   --  not encountered a referencer so far. We only reset
 592                   --  the flag for outer level entities that are not
 593                   --  imported/exported, and which have no interface name.
 594
 595                   elsif K = N_Object_Declaration
 596                     or else K = N_Exception_Declaration
 597                     or else K = N_Subprogram_Declaration
 598                   then
 599                      E := Defining_Entity (D);
 600
 601                      if Outer
 602                        and then not Is_Imported (E)
 603                        and then not Is_Exported (E)
 604                        and then No (Interface_Name (E))
 605                      then
 606                         Set_Is_Public (E, False);
 607                      end if;
 608                   end if;
 609
 610                   Prev (D);
 611                end loop;
 612
 613                return False;
 614             end Has_Referencer;
 615
 616          --  Start of processing for Make_Non_Public_Where_Possible
 617
 618          begin
 619             declare
 620                Discard : Boolean;
 621                pragma Warnings (Off, Discard);
 622
 623             begin
 624                Discard := Has_Referencer (Declarations (N), Outer => True);
 625             end;
 626          end Make_Non_Public_Where_Possible;
 627       end if;
 628
 629       --  If expander is not active, then here is where we turn off the
 630       --  In_Package_Body flag, otherwise it is turned off at the end of
 631       --  the corresponding expansion routine. If this is an instance body,
 632       --  we need to qualify names of local entities, because the body may
 633       --  have been compiled as a preliminary to another instantiation.
 634
 635       if not Expander_Active then
 636          Set_In_Package_Body (Spec_Id, False);
 637
 638          if Is_Generic_Instance (Spec_Id)
 639            and then Operating_Mode = Generate_Code
 640          then
 641             Qualify_Entity_Names (N);
 642          end if;
 643       end if;
 644    end Analyze_Package_Body;
 645
 646    ---------------------------------
 647    -- Analyze_Package_Declaration --
 648    ---------------------------------
 649
 650    procedure Analyze_Package_Declaration (N : Node_Id) is
 651       Id : constant Node_Id := Defining_Entity (N);
 652
 653       PF : Boolean;
 654       --  True when in the context of a declared pure library unit
 655
 656       Body_Required : Boolean;
 657       --  True when this package declaration requires a corresponding body
 658
 659       Comp_Unit : Boolean;
 660       --  True when this package declaration is not a nested declaration
 661
 662    begin
 663       --  Ada 2005 (AI-217): Check if the package has been erroneously named
 664       --  in a limited-with clause of its own context. In this case the error
 665       --  has been previously notified by Analyze_Context.
 666
 667       --     limited with Pkg; -- ERROR
 668       --     package Pkg is ...
 669
 670       if From_With_Type (Id) then
 671          return;
 672       end if;
 673
 674       Generate_Definition (Id);
 675       Enter_Name (Id);
 676       Set_Ekind (Id, E_Package);
 677       Set_Etype (Id, Standard_Void_Type);
 678
 679       New_Scope (Id);
 680
 681       PF := Is_Pure (Enclosing_Lib_Unit_Entity);
 682       Set_Is_Pure (Id, PF);
 683
 684       Set_Categorization_From_Pragmas (N);
 685
 686       if Debug_Flag_C then
 687          Write_Str ("====  Compiling package spec ");
 688          Write_Name (Chars (Id));
 689          Write_Str (" from ");
 690          Write_Location (Sloc (N));
 691          Write_Eol;
 692       end if;
 693
 694       Analyze (Specification (N));
 695       Validate_Categorization_Dependency (N, Id);
 696
 697       Body_Required := Unit_Requires_Body (Id);
 698
 699       --  When this spec does not require an explicit body, we know that
 700       --  there are no entities requiring completion in the language sense;
 701       --  we call Check_Completion here only to ensure that any nested package
 702       --  declaration that requires an implicit body gets one. (In the case
 703       --  where a body is required, Check_Completion is called at the end of
 704       --  the body's declarative part.)
 705
 706       if not Body_Required then
 707          Check_Completion;
 708       end if;
 709
 710       Comp_Unit := Nkind (Parent (N)) = N_Compilation_Unit;
 711       if Comp_Unit then
 712
 713          --  Set Body_Required indication on the compilation unit node, and
 714          --  determine whether elaboration warnings may be meaningful on it.
 715
 716          Set_Body_Required (Parent (N), Body_Required);
 717
 718          if not Body_Required then
 719             Set_Suppress_Elaboration_Warnings (Id);
 720          end if;
 721
 722       end if;
 723
 724       End_Package_Scope (Id);
 725
 726       --  For the declaration of a library unit that is a remote types package,
 727       --  check legality rules regarding availability of stream attributes for
 728       --  types that contain non-remote access values. This subprogram performs
 729       --  visibility tests that rely on the fact that we have exited the scope
 730       --  of Id.
 731
 732       if Comp_Unit then
 733          Validate_RT_RAT_Component (N);
 734       end if;
 735    end Analyze_Package_Declaration;
 736
 737    -----------------------------------
 738    -- Analyze_Package_Specification --
 739    -----------------------------------
 740
 741    --  Note that this code is shared for the analysis of generic package
 742    --  specs (see Sem_Ch12.Analyze_Generic_Package_Declaration for details).
 743
 744    procedure Analyze_Package_Specification (N : Node_Id) is
 745       Id           : constant Entity_Id  := Defining_Entity (N);
 746       Orig_Decl    : constant Node_Id    := Original_Node (Parent (N));
 747       Vis_Decls    : constant List_Id    := Visible_Declarations (N);
 748       Priv_Decls   : constant List_Id    := Private_Declarations (N);
 749       E            : Entity_Id;
 750       L            : Entity_Id;
 751       Public_Child : Boolean;
 752
 753       Private_With_Clauses_Installed : Boolean := False;
 754       --  In Ada 2005, private with_clauses are visible in the private part
 755       --  of a nested package, even if it appears in the public part of the
 756       --  enclosing package. This requires a separate step to install these
 757       --  private_with_clauses, and remove them at the end of the nested
 758       --  package.
 759
 760       procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
 761       --  Clears constant indications (Never_Set_In_Source, Constant_Value,
 762       --  and Is_True_Constant) on all variables that are entities of Id,
 763       --  and on the chain whose first element is FE. A recursive call is
 764       --  made for all packages and generic packages.
 765
 766       procedure Generate_Parent_References;
 767       --  For a child unit, generate references to parent units, for
 768       --  GPS navigation purposes.
 769
 770       function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
 771       --  Child and Unit are entities of compilation units. True if Child
 772       --  is a public child of Parent as defined in 10.1.1
 773
 774       procedure Inspect_Unchecked_Union_Completion (Decls : List_Id);
 775       --  Detects all incomplete or private type declarations having a known
 776       --  discriminant part that are completed by an Unchecked_Union. Emits
 777       --  the error message "Unchecked_Union may not complete discriminated
 778       --  partial view".
 779
 780       procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id);
 781       --  Given the package entity of a generic package instantiation or
 782       --  formal package whose corresponding generic is a child unit, installs
 783       --  the private declarations of each of the child unit's parents.
 784       --  This has to be done at the point of entering the instance package's
 785       --  private part rather than being done in Sem_Ch12.Install_Parent
 786       --  (which is where the parents' visible declarations are installed).
 787
 788       ---------------------
 789       -- Clear_Constants --
 790       ---------------------
 791
 792       procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is
 793          E : Entity_Id;
 794
 795       begin
 796          --  Ignore package renamings, not interesting and they can
 797          --  cause self referential loops in the code below.
 798
 799          if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then
 800             return;
 801          end if;
 802
 803          --  Note: in the loop below, the check for Next_Entity pointing
 804          --  back to the package entity may seem odd, but it is needed,
 805          --  because a package can contain a renaming declaration to itself,
 806          --  and such renamings are generated automatically within package
 807          --  instances.
 808
 809          E := FE;
 810          while Present (E) and then E /= Id loop
 811             if Ekind (E) = E_Variable then
 812                Set_Never_Set_In_Source (E, False);
 813                Set_Is_True_Constant    (E, False);
 814                Set_Current_Value       (E, Empty);
 815                Set_Is_Known_Null       (E, False);
 816                Set_Last_Assignment     (E, Empty);
 817
 818                if not Can_Never_Be_Null (E) then
 819                   Set_Is_Known_Non_Null (E, False);
 820                end if;
 821
 822             elsif Ekind (E) = E_Package
 823                     or else
 824                   Ekind (E) = E_Generic_Package
 825             then
 826                Clear_Constants (E, First_Entity (E));
 827                Clear_Constants (E, First_Private_Entity (E));
 828             end if;
 829
 830             Next_Entity (E);
 831          end loop;
 832       end Clear_Constants;
 833
 834       --------------------------------
 835       -- Generate_Parent_References --
 836       --------------------------------
 837
 838       procedure Generate_Parent_References is
 839          Decl : constant Node_Id := Parent (N);
 840
 841       begin
 842          if Id = Cunit_Entity (Main_Unit)
 843            or else Parent (Decl) = Library_Unit (Cunit (Main_Unit))
 844          then
 845             Generate_Reference (Id, Scope (Id), 'k', False);
 846
 847          elsif Nkind (Unit (Cunit (Main_Unit))) /= N_Subprogram_Body
 848            and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
 849          then
 850             --  If current unit is an ancestor of main unit, generate
 851             --  a reference to its own parent.
 852
 853             declare
 854                U         : Node_Id;
 855                Main_Spec : Node_Id := Unit (Cunit (Main_Unit));
 856
 857             begin
 858                if Nkind (Main_Spec) = N_Package_Body then
 859                   Main_Spec := Unit (Library_Unit (Cunit (Main_Unit)));
 860                end if;
 861
 862                U := Parent_Spec (Main_Spec);
 863                while Present (U) loop
 864                   if U = Parent (Decl) then
 865                      Generate_Reference (Id, Scope (Id), 'k',  False);
 866                      exit;
 867
 868                   elsif Nkind (Unit (U)) = N_Package_Body then
 869                      exit;
 870
 871                   else
 872                      U := Parent_Spec (Unit (U));
 873                   end if;
 874                end loop;
 875             end;
 876          end if;
 877       end Generate_Parent_References;
 878
 879       ---------------------
 880       -- Is_Public_Child --
 881       ---------------------
 882
 883       function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is
 884       begin
 885          if not Is_Private_Descendant (Child) then
 886             return True;
 887          else
 888             if Child = Unit then
 889                return not Private_Present (
 890                  Parent (Unit_Declaration_Node (Child)));
 891             else
 892                return Is_Public_Child (Scope (Child), Unit);
 893             end if;
 894          end if;
 895       end Is_Public_Child;
 896
 897       ----------------------------------------
 898       -- Inspect_Unchecked_Union_Completion --
 899       ----------------------------------------
 900
 901       procedure Inspect_Unchecked_Union_Completion (Decls : List_Id) is
 902          Decl : Node_Id;
 903
 904       begin
 905          Decl := First (Decls);
 906          while Present (Decl) loop
 907
 908             --  We are looking at an incomplete or private type declaration
 909             --  with a known_discriminant_part whose full view is an
 910             --  Unchecked_Union.
 911
 912             if (Nkind (Decl) = N_Incomplete_Type_Declaration
 913                   or else
 914                 Nkind (Decl) = N_Private_Type_Declaration)
 915               and then Has_Discriminants (Defining_Identifier (Decl))
 916               and then Present (Full_View (Defining_Identifier (Decl)))
 917               and then Is_Unchecked_Union
 918                 (Full_View (Defining_Identifier (Decl)))
 919             then
 920                Error_Msg_N ("completion of discriminated partial view" &
 921                  " cannot be an Unchecked_Union",
 922                  Full_View (Defining_Identifier (Decl)));
 923             end if;
 924
 925             Next (Decl);
 926          end loop;
 927       end Inspect_Unchecked_Union_Completion;
 928
 929       -----------------------------------------
 930       -- Install_Parent_Private_Declarations --
 931       -----------------------------------------
 932
 933       procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id) is
 934          Inst_Par  : Entity_Id;
 935          Gen_Par   : Entity_Id;
 936          Inst_Node : Node_Id;
 937
 938       begin
 939          Inst_Par := Inst_Id;
 940          Gen_Par :=
 941            Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
 942          while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
 943             Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
 944
 945             if (Nkind (Inst_Node) = N_Package_Instantiation
 946                   or else Nkind (Inst_Node) = N_Formal_Package_Declaration)
 947               and then Nkind (Name (Inst_Node)) = N_Expanded_Name
 948             then
 949                Inst_Par := Entity (Prefix (Name (Inst_Node)));
 950
 951                if Present (Renamed_Entity (Inst_Par)) then
 952                   Inst_Par := Renamed_Entity (Inst_Par);
 953                end if;
 954
 955                Gen_Par :=
 956                  Generic_Parent
 957                    (Specification (Unit_Declaration_Node (Inst_Par)));
 958
 959                --  Install the private declarations and private use clauses
 960                --  of a parent instance of the child instance, unless the
 961                --  parent instance private declarations have already been
 962                --  installed earlier in Analyze_Package_Specification, which
 963                --  happens when a generic child is instantiated, and the
 964                --  instance is a child of the parent instance.
 965
 966                --  Installing the use clauses of the parent instance twice is
 967                --  both unnecessary and wrong, because it would cause the
 968                --  clauses to be chained to themselves in the use clauses list
 969                --  of the scope stack entry. That in turn would cause
 970                --  End_Use_Clauses to get into an endless look upon scope exit.
 971
 972                if Present (Gen_Par) then
 973                   if not In_Private_Part (Inst_Par) then
 974                      Install_Private_Declarations (Inst_Par);
 975                      Set_Use (Private_Declarations
 976                                 (Specification
 977                                    (Unit_Declaration_Node (Inst_Par))));
 978                   end if;
 979
 980                --  If we've reached the end of the generic instance parents,
 981                --  then finish off by looping through the nongeneric parents
 982                --  and installing their private declarations.
 983
 984                else
 985                   while Present (Inst_Par)
 986                     and then Inst_Par /= Standard_Standard
 987                     and then (not In_Open_Scopes (Inst_Par)
 988                                 or else not In_Private_Part (Inst_Par))
 989                   loop
 990                      Install_Private_Declarations (Inst_Par);
 991                      Set_Use (Private_Declarations
 992                                 (Specification
 993                                    (Unit_Declaration_Node (Inst_Par))));
 994                      Inst_Par := Scope (Inst_Par);
 995                   end loop;
 996
 997                   exit;
 998                end if;
 999
1000             else
1001                exit;
1002             end if;
1003          end loop;
1004       end Install_Parent_Private_Declarations;
1005
1006    --  Start of processing for Analyze_Package_Specification
1007
1008    begin
1009       if Present (Vis_Decls) then
1010          Analyze_Declarations (Vis_Decls);
1011       end if;
1012
1013       --  Verify that incomplete types have received full declarations
1014
1015       E := First_Entity (Id);
1016       while Present (E) loop
1017          if Ekind (E) = E_Incomplete_Type
1018            and then No (Full_View (E))
1019          then
1020             Error_Msg_N ("no declaration in visible part for incomplete}", E);
1021          end if;
1022
1023          Next_Entity (E);
1024       end loop;
1025
1026       if Is_Remote_Call_Interface (Id)
1027          and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
1028       then
1029          Validate_RCI_Declarations (Id);
1030       end if;
1031
1032       --  Save global references in the visible declarations, before
1033       --  installing private declarations of parent unit if there is one,
1034       --  because the privacy status of types defined in the parent will
1035       --  change. This is only relevant for generic child units, but is
1036       --  done in all cases for uniformity.
1037
1038       if Ekind (Id) = E_Generic_Package
1039         and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
1040       then
1041          declare
1042             Orig_Spec : constant Node_Id    := Specification (Orig_Decl);
1043             Save_Priv : constant List_Id := Private_Declarations (Orig_Spec);
1044
1045          begin
1046             Set_Private_Declarations (Orig_Spec, Empty_List);
1047             Save_Global_References   (Orig_Decl);
1048             Set_Private_Declarations (Orig_Spec, Save_Priv);
1049          end;
1050       end if;
1051
1052       --  If package is a public child unit, then make the private declarations
1053       --  of the parent visible.
1054
1055       Public_Child := False;
1056
1057       declare
1058          Par       : Entity_Id;
1059          Pack_Decl : Node_Id;
1060          Par_Spec  : Node_Id;
1061
1062       begin
1063          Par := Id;
1064          Par_Spec := Parent_Spec (Parent (N));
1065
1066          --  If the package is formal package of an enclosing generic, it is
1067          --  transformed into a local generic declaration, and compiled to make
1068          --  its spec available. We need to retrieve the original generic to
1069          --  determine whether it is a child unit, and install its parents.
1070
1071          if No (Par_Spec)
1072            and then
1073              Nkind (Original_Node (Parent (N))) = N_Formal_Package_Declaration
1074          then
1075             Par := Entity (Name (Original_Node (Parent (N))));
1076             Par_Spec := Parent_Spec (Unit_Declaration_Node (Par));
1077          end if;
1078
1079          if Present (Par_Spec) then
1080             Generate_Parent_References;
1081
1082             while Scope (Par) /= Standard_Standard
1083               and then Is_Public_Child (Id, Par)
1084               and then In_Open_Scopes (Par)
1085             loop
1086                Public_Child := True;
1087                Par := Scope (Par);
1088                Install_Private_Declarations (Par);
1089                Install_Private_With_Clauses (Par);
1090                Pack_Decl := Unit_Declaration_Node (Par);
1091                Set_Use (Private_Declarations (Specification (Pack_Decl)));
1092             end loop;
1093          end if;
1094       end;
1095
1096       if Is_Compilation_Unit (Id) then
1097          Install_Private_With_Clauses (Id);
1098       else
1099
1100          --  The current compilation unit may include private with_clauses,
1101          --  which are visible in the private part of the current nested
1102          --  package, and have to be installed now.
1103
1104          declare
1105             Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
1106          begin
1107             if (Ekind (Comp_Unit) = E_Package
1108                  or else Ekind (Comp_Unit) = E_Generic_Package)
1109               and then not In_Private_Part (Comp_Unit)
1110             then
1111                Install_Private_With_Clauses (Comp_Unit);
1112                Private_With_Clauses_Installed := True;
1113             end if;
1114          end;
1115       end if;
1116
1117       --  If this is a package associated with a generic instance or formal
1118       --  package, then the private declarations of each of the generic's
1119       --  parents must be installed at this point.
1120
1121       if Is_Generic_Instance (Id) then
1122          Install_Parent_Private_Declarations (Id);
1123       end if;
1124
1125       --  Analyze private part if present. The flag In_Private_Part is reset
1126       --  in End_Package_Scope.
1127
1128       L := Last_Entity (Id);
1129
1130       if Present (Priv_Decls) then
1131          Set_In_Private_Part (Id);
1132
1133          --  Upon entering a public child's private part, it may be necessary
1134          --  to declare subprograms that were derived in the package's visible
1135          --  part but not yet made visible.
1136
1137          if Public_Child then
1138             Declare_Inherited_Private_Subprograms (Id);
1139          end if;
1140
1141          Analyze_Declarations (Priv_Decls);
1142
1143          --  Check the private declarations for incomplete deferred constants
1144
1145          Inspect_Deferred_Constant_Completion (Priv_Decls);
1146
1147          --  The first private entity is the immediate follower of the last
1148          --  visible entity, if there was one.
1149
1150          if Present (L) then
1151             Set_First_Private_Entity (Id, Next_Entity (L));
1152          else
1153             Set_First_Private_Entity (Id, First_Entity (Id));
1154          end if;
1155
1156       --  There may be inherited private subprograms that need to be declared,
1157       --  even in the absence of an explicit private part.  If there are any
1158       --  public declarations in the package and the package is a public child
1159       --  unit, then an implicit private part is assumed.
1160
1161       elsif Present (L) and then Public_Child then
1162          Set_In_Private_Part (Id);
1163          Declare_Inherited_Private_Subprograms (Id);
1164          Set_First_Private_Entity (Id, Next_Entity (L));
1165       end if;
1166
1167       --  Check rule of 3.6(11), which in general requires waiting till all
1168       --  full types have been seen.
1169
1170       E := First_Entity (Id);
1171       while Present (E) loop
1172          if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then
1173             Check_Aliased_Component_Types (E);
1174          end if;
1175
1176          Next_Entity (E);
1177       end loop;
1178
1179       --  Ada 2005 (AI-216): The completion of an incomplete or private type
1180       --  declaration having a known_discriminant_part shall not be an
1181       --  Unchecked_Union type.
1182
1183       if Present (Vis_Decls) then
1184          Inspect_Unchecked_Union_Completion (Vis_Decls);
1185       end if;
1186
1187       if Present (Priv_Decls) then
1188          Inspect_Unchecked_Union_Completion (Priv_Decls);
1189       end if;
1190
1191       if Ekind (Id) = E_Generic_Package
1192         and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
1193         and then Present (Priv_Decls)
1194       then
1195          --  Save global references in private declarations, ignoring the
1196          --  visible declarations that were processed earlier.
1197
1198          declare
1199             Orig_Spec : constant Node_Id := Specification (Orig_Decl);
1200             Save_Vis  : constant List_Id := Visible_Declarations (Orig_Spec);
1201             Save_Form : constant List_Id :=
1202                           Generic_Formal_Declarations (Orig_Decl);
1203
1204          begin
1205             Set_Visible_Declarations        (Orig_Spec, Empty_List);
1206             Set_Generic_Formal_Declarations (Orig_Decl, Empty_List);
1207             Save_Global_References          (Orig_Decl);
1208             Set_Generic_Formal_Declarations (Orig_Decl, Save_Form);
1209             Set_Visible_Declarations        (Orig_Spec, Save_Vis);
1210          end;
1211       end if;
1212
1213       Process_End_Label (N, 'e', Id);
1214
1215       --  Remove private_with_clauses of enclosing compilation unit, if they
1216       --  were installed.
1217
1218       if Private_With_Clauses_Installed then
1219          Remove_Private_With_Clauses (Cunit (Current_Sem_Unit));
1220       end if;
1221
1222       --  For the case of a library level package, we must go through all the
1223       --  entities clearing the indications that the value may be constant and
1224       --  not modified. Why? Because any client of this package may modify
1225       --  these values freely from anywhere. This also applies to any nested
1226       --  packages or generic packages.
1227
1228       --  For now we unconditionally clear constants for packages that are
1229       --  instances of generic packages. The reason is that we do not have the
1230       --  body yet, and we otherwise think things are unreferenced when they
1231       --  are not. This should be fixed sometime (the effect is not terrible,
1232       --  we just lose some warnings, and also some cases of value propagation)
1233       --  ???
1234
1235       if Is_Library_Level_Entity (Id)
1236         or else Is_Generic_Instance (Id)
1237       then
1238          Clear_Constants (Id, First_Entity (Id));
1239          Clear_Constants (Id, First_Private_Entity (Id));
1240       end if;
1241    end Analyze_Package_Specification;
1242
1243    --------------------------------------
1244    -- Analyze_Private_Type_Declaration --
1245    --------------------------------------
1246
1247    procedure Analyze_Private_Type_Declaration (N : Node_Id) is
1248       PF : constant Boolean   := Is_Pure (Enclosing_Lib_Unit_Entity);
1249       Id : constant Entity_Id := Defining_Identifier (N);
1250
1251    begin
1252       Generate_Definition (Id);
1253       Set_Is_Pure         (Id, PF);
1254       Init_Size_Align     (Id);
1255
1256       if (Ekind (Current_Scope) /= E_Package
1257           and then Ekind (Current_Scope) /= E_Generic_Package)
1258         or else In_Private_Part (Current_Scope)
1259       then
1260          Error_Msg_N ("invalid context for private declaration", N);
1261       end if;
1262
1263       New_Private_Type (N, Id, N);
1264       Set_Depends_On_Private (Id);
1265    end Analyze_Private_Type_Declaration;
1266
1267    ----------------------------------
1268    -- Check_Anonymous_Access_Types --
1269    ----------------------------------
1270
1271    procedure Check_Anonymous_Access_Types
1272      (Spec_Id : Entity_Id;
1273       P_Body  : Node_Id)
1274    is
1275       E  : Entity_Id;
1276       IR : Node_Id;
1277
1278    begin
1279       --  Itype references are only needed by gigi, to force elaboration of
1280       --  itypes. In the absence of code generation, they are not needed.
1281
1282       if not Expander_Active then
1283          return;
1284       end if;
1285
1286       E := First_Entity (Spec_Id);
1287       while Present (E) loop
1288          if Ekind (E) = E_Anonymous_Access_Type
1289            and then From_With_Type (E)
1290          then
1291             IR := Make_Itype_Reference (Sloc (P_Body));
1292             Set_Itype (IR, E);
1293
1294             if No (Declarations (P_Body)) then
1295                Set_Declarations (P_Body, New_List);
1296             end if;
1297
1298             Insert_Before (First (Declarations (P_Body)), IR);
1299          end if;
1300
1301          Next_Entity (E);
1302       end loop;
1303    end Check_Anonymous_Access_Types;
1304
1305    -------------------------------------------
1306    -- Declare_Inherited_Private_Subprograms --
1307    -------------------------------------------
1308
1309    procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
1310       E              : Entity_Id;
1311       Op_List        : Elist_Id;
1312       Op_Elmt        : Elmt_Id;
1313       Op_Elmt_2      : Elmt_Id;
1314       Prim_Op        : Entity_Id;
1315       New_Op         : Entity_Id := Empty;
1316       Parent_Subp    : Entity_Id;
1317       Found_Explicit : Boolean;
1318       Decl_Privates  : Boolean;
1319
1320       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
1321       --  Check whether an inherited subprogram is an operation of an
1322       --  untagged derived type.
1323
1324       ---------------------
1325       -- Is_Primitive_Of --
1326       ---------------------
1327
1328       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is
1329          Formal : Entity_Id;
1330
1331       begin
1332          if Etype (S) = T then
1333             return True;
1334
1335          else
1336             Formal := First_Formal (S);
1337             while Present (Formal) loop
1338                if Etype (Formal) = T then
1339                   return True;
1340                end if;
1341
1342                Next_Formal (Formal);
1343             end loop;
1344
1345             return False;
1346          end if;
1347       end Is_Primitive_Of;
1348
1349    --  Start of processing for Declare_Inherited_Private_Subprograms
1350
1351    begin
1352       E := First_Entity (Id);
1353       while Present (E) loop
1354
1355          --  If the entity is a nonprivate type extension whose parent
1356          --  type is declared in an open scope, then the type may have
1357          --  inherited operations that now need to be made visible.
1358          --  Ditto if the entity is a formal derived type in a child unit.
1359
1360          if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
1361                or else
1362                  (Nkind (Parent (E)) = N_Private_Extension_Declaration
1363                    and then Is_Generic_Type (E)))
1364            and then In_Open_Scopes (Scope (Etype (E)))
1365            and then E = Base_Type (E)
1366          then
1367             if Is_Tagged_Type (E) then
1368                Op_List       := Primitive_Operations (E);
1369                New_Op        := Empty;
1370                Decl_Privates := False;
1371
1372                Op_Elmt := First_Elmt (Op_List);
1373                while Present (Op_Elmt) loop
1374                   Prim_Op := Node (Op_Elmt);
1375
1376                   --  If the primitive operation is an implicit operation
1377                   --  with an internal name whose parent operation has
1378                   --  a normal name, then we now need to either declare the
1379                   --  operation (i.e., make it visible), or replace it
1380                   --  by an overriding operation if one exists.
1381
1382                   if Present (Alias (Prim_Op))
1383                     and then Find_Dispatching_Type (Alias (Prim_Op)) /= E
1384                     and then not Comes_From_Source (Prim_Op)
1385                     and then Is_Internal_Name (Chars (Prim_Op))
1386                     and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
1387                   then
1388                      Parent_Subp := Alias (Prim_Op);
1389
1390                      Found_Explicit := False;
1391                      Op_Elmt_2 := Next_Elmt (Op_Elmt);
1392                      while Present (Op_Elmt_2) loop
1393                         if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
1394                           and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
1395                         then
1396                            --  The private inherited operation has been
1397                            --  overridden by an explicit subprogram, so
1398                            --  change the private op's list element to
1399                            --  designate the explicit so the explicit
1400                            --  one will get the right dispatching slot.
1401
1402                            New_Op := Node (Op_Elmt_2);
1403                            Replace_Elmt (Op_Elmt, New_Op);
1404                            Remove_Elmt (Op_List, Op_Elmt_2);
1405                            Found_Explicit := True;
1406                            Set_Is_Overriding_Operation (New_Op);
1407                            Decl_Privates  := True;
1408
1409                            exit;
1410                         end if;
1411
1412                         Next_Elmt (Op_Elmt_2);
1413                      end loop;
1414
1415                      if not Found_Explicit then
1416                         Derive_Subprogram
1417                           (New_Op, Alias (Prim_Op), E, Etype (E));
1418
1419                         pragma Assert
1420                           (Is_Dispatching_Operation (New_Op)
1421                             and then Node (Last_Elmt (Op_List)) = New_Op);
1422
1423                         --  Substitute the new operation for the old one
1424                         --  in the type's primitive operations list. Since
1425                         --  the new operation was also just added to the end
1426                         --  of list, the last element must be removed.
1427
1428                         --  (Question: is there a simpler way of declaring
1429                         --  the operation, say by just replacing the name
1430                         --  of the earlier operation, reentering it in the
1431                         --  in the symbol table (how?), and marking it as
1432                         --  private???)
1433
1434                         Replace_Elmt (Op_Elmt, New_Op);
1435                         Remove_Last_Elmt (Op_List);
1436                         Decl_Privates := True;
1437                      end if;
1438                   end if;
1439
1440                   Next_Elmt (Op_Elmt);
1441                end loop;
1442
1443                --  The type's DT attributes need to be recalculated
1444                --  in the case where private dispatching operations
1445                --  have been added or overridden. Normally this action
1446                --  occurs during type freezing, but we force it here
1447                --  since the type may already have been frozen (e.g.,
1448                --  if the type's package has an empty private part).
1449                --  This can only be done if expansion is active, otherwise
1450                --  Tag may not be present.
1451
1452                if Decl_Privates
1453                  and then Expander_Active
1454                then
1455                   Set_All_DT_Position (E);
1456                end if;
1457
1458             else
1459                --   Non-tagged type, scan forward to locate
1460                --   inherited hidden operations.
1461
1462                Prim_Op := Next_Entity (E);
1463                while Present (Prim_Op) loop
1464                   if Is_Subprogram (Prim_Op)
1465                     and then Present (Alias (Prim_Op))
1466                     and then not Comes_From_Source (Prim_Op)
1467                     and then Is_Internal_Name (Chars (Prim_Op))
1468                     and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
1469                     and then Is_Primitive_Of (E, Prim_Op)
1470                   then
1471                      Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
1472                   end if;
1473
1474                   Next_Entity (Prim_Op);
1475                end loop;
1476             end if;
1477          end if;
1478
1479          Next_Entity (E);
1480       end loop;
1481    end Declare_Inherited_Private_Subprograms;
1482
1483    -----------------------
1484    -- End_Package_Scope --
1485    -----------------------
1486
1487    procedure End_Package_Scope (P : Entity_Id) is
1488    begin
1489       Uninstall_Declarations (P);
1490       Pop_Scope;
1491    end End_Package_Scope;
1492
1493    ---------------------------
1494    -- Exchange_Declarations --
1495    ---------------------------
1496
1497    procedure Exchange_Declarations (Id : Entity_Id) is
1498       Full_Id : constant Entity_Id := Full_View (Id);
1499       H1      : constant Entity_Id := Homonym (Id);
1500       Next1   : constant Entity_Id := Next_Entity (Id);
1501       H2      : Entity_Id;
1502       Next2   : Entity_Id;
1503
1504    begin
1505       --  If missing full declaration for type, nothing to exchange
1506
1507       if No (Full_Id) then
1508          return;
1509       end if;
1510
1511       --  Otherwise complete the exchange, and preserve semantic links
1512
1513       Next2 := Next_Entity (Full_Id);
1514       H2    := Homonym (Full_Id);
1515
1516       --  Reset full declaration pointer to reflect the switched entities
1517       --  and readjust the next entity chains.
1518
1519       Exchange_Entities (Id, Full_Id);
1520
1521       Set_Next_Entity (Id, Next1);
1522       Set_Homonym     (Id, H1);
1523
1524       Set_Full_View   (Full_Id, Id);
1525       Set_Next_Entity (Full_Id, Next2);
1526       Set_Homonym     (Full_Id, H2);
1527    end Exchange_Declarations;
1528
1529    ------------------------------------------
1530    -- Inspect_Deferred_Constant_Completion --
1531    ------------------------------------------
1532
1533    procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
1534       Decl   : Node_Id;
1535
1536    begin
1537       Decl := First (Decls);
1538       while Present (Decl) loop
1539
1540          --  Deferred constant signature
1541
1542          if Nkind (Decl) = N_Object_Declaration
1543            and then Constant_Present (Decl)
1544            and then No (Expression (Decl))
1545
1546             --  No need to check internally generated constants
1547
1548            and then Comes_From_Source (Decl)
1549
1550             --  The constant is not completed. A full object declaration
1551             --  or a pragma Import complete a deferred constant.
1552
1553            and then not Has_Completion (Defining_Identifier (Decl))
1554          then
1555             Error_Msg_N
1556               ("constant declaration requires initialization expression",
1557               Defining_Identifier (Decl));
1558          end if;
1559
1560          Decl := Next (Decl);
1561       end loop;
1562    end Inspect_Deferred_Constant_Completion;
1563
1564    ----------------------------
1565    -- Install_Package_Entity --
1566    ----------------------------
1567
1568    procedure Install_Package_Entity (Id : Entity_Id) is
1569    begin
1570       if not Is_Internal (Id) then
1571          if Debug_Flag_E then
1572             Write_Str ("Install: ");
1573             Write_Name (Chars (Id));
1574             Write_Eol;
1575          end if;
1576
1577          if not Is_Child_Unit (Id) then
1578             Set_Is_Immediately_Visible (Id);
1579          end if;
1580
1581       end if;
1582    end Install_Package_Entity;
1583
1584    ----------------------------------
1585    -- Install_Private_Declarations --
1586    ----------------------------------
1587
1588    procedure Install_Private_Declarations (P : Entity_Id) is
1589       Id        : Entity_Id;
1590       Priv_Elmt : Elmt_Id;
1591       Priv      : Entity_Id;
1592       Full      : Entity_Id;
1593
1594    begin
1595       --  First exchange declarations for private types, so that the
1596       --  full declaration is visible. For each private type, we check
1597       --  its Private_Dependents list and also exchange any subtypes of
1598       --  or derived types from it. Finally, if this is a Taft amendment
1599       --  type, the incomplete declaration is irrelevant, and we want to
1600       --  link the eventual full declaration with the original private
1601       --  one so we also skip the exchange.
1602
1603       Id := First_Entity (P);
1604       while Present (Id) and then Id /= First_Private_Entity (P) loop
1605          if Is_Private_Base_Type (Id)
1606            and then Comes_From_Source (Full_View (Id))
1607            and then Present (Full_View (Id))
1608            and then Scope (Full_View (Id)) = Scope (Id)
1609            and then Ekind (Full_View (Id)) /= E_Incomplete_Type
1610          then
1611             --  If there is a use-type clause on the private type, set the
1612             --  full view accordingly.
1613
1614             Set_In_Use (Full_View (Id), In_Use (Id));
1615             Full := Full_View (Id);
1616
1617             if Is_Private_Base_Type (Full)
1618               and then Has_Private_Declaration (Full)
1619               and then Nkind (Parent (Full)) = N_Full_Type_Declaration
1620               and then In_Open_Scopes (Scope (Etype (Full)))
1621               and then In_Package_Body (Current_Scope)
1622               and then not Is_Private_Type (Etype (Full))
1623             then
1624                --  This is the completion of a private type by a derivation
1625                --  from another private type which is not private anymore. This
1626                --  can only happen in a package nested within a child package,
1627                --  when the parent type is defined in the parent unit. At this
1628                --  point the current type is not private either, and we have to
1629                --  install the underlying full view, which is now visible.
1630
1631                if No (Full_View (Full))
1632                  and then Present (Underlying_Full_View (Full))
1633                then
1634                   Set_Full_View (Id, Underlying_Full_View (Full));
1635                   Set_Underlying_Full_View (Full, Empty);
1636                   Set_Is_Frozen (Full_View (Id));
1637                end if;
1638             end if;
1639
1640             Priv_Elmt := First_Elmt (Private_Dependents (Id));
1641
1642             Exchange_Declarations (Id);
1643             Set_Is_Immediately_Visible (Id);
1644
1645             while Present (Priv_Elmt) loop
1646                Priv := Node (Priv_Elmt);
1647
1648                --  Before the exchange, verify that the presence of the
1649                --  Full_View field. It will be empty if the entity
1650                --  has already been installed due to a previous call.
1651
1652                if Present (Full_View (Priv))
1653                  and then Is_Visible_Dependent (Priv)
1654                then
1655
1656                   --  For each subtype that is swapped, we also swap the
1657                   --  reference to it in Private_Dependents, to allow access
1658                   --  to it when we swap them out in End_Package_Scope.
1659
1660                   Replace_Elmt (Priv_Elmt, Full_View (Priv));
1661                   Exchange_Declarations (Priv);
1662                   Set_Is_Immediately_Visible
1663                     (Priv, In_Open_Scopes (Scope (Priv)));
1664                   Set_Is_Potentially_Use_Visible
1665                     (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
1666                end if;
1667
1668                Next_Elmt (Priv_Elmt);
1669             end loop;
1670          end if;
1671
1672          Next_Entity (Id);
1673       end loop;
1674
1675       --  Next make other declarations in the private part visible as well
1676
1677       Id := First_Private_Entity (P);
1678       while Present (Id) loop
1679          Install_Package_Entity (Id);
1680          Set_Is_Hidden (Id, False);
1681          Next_Entity (Id);
1682       end loop;
1683
1684       --  Indicate that the private part is currently visible, so it can be
1685       --  properly reset on exit.
1686
1687       Set_In_Private_Part (P);
1688    end Install_Private_Declarations;
1689
1690    ----------------------------------
1691    -- Install_Visible_Declarations --
1692    ----------------------------------
1693
1694    procedure Install_Visible_Declarations (P : Entity_Id) is
1695       Id          : Entity_Id;
1696       Last_Entity : Entity_Id;
1697
1698    begin
1699       pragma Assert
1700         (Is_Package_Or_Generic_Package (P) or else Is_Record_Type (P));
1701
1702       if Is_Package_Or_Generic_Package (P) then
1703          Last_Entity := First_Private_Entity (P);
1704       else
1705          Last_Entity := Empty;
1706       end if;
1707
1708       Id := First_Entity (P);
1709       while Present (Id) and then Id /= Last_Entity loop
1710          Install_Package_Entity (Id);
1711          Next_Entity (Id);
1712       end loop;
1713    end Install_Visible_Declarations;
1714
1715    --------------------------
1716    -- Is_Private_Base_Type --
1717    --------------------------
1718
1719    function Is_Private_Base_Type (E : Entity_Id) return Boolean is
1720    begin
1721       return Ekind (E) = E_Private_Type
1722         or else Ekind (E) = E_Limited_Private_Type
1723         or else Ekind (E) = E_Record_Type_With_Private;
1724    end Is_Private_Base_Type;
1725
1726    --------------------------
1727    -- Is_Visible_Dependent --
1728    --------------------------
1729
1730    function Is_Visible_Dependent (Dep : Entity_Id) return Boolean
1731    is
1732       S : constant Entity_Id := Scope (Dep);
1733
1734    begin
1735       --  Renamings created for actual types have the visibility of the
1736       --  actual.
1737
1738       if Ekind (S) = E_Package
1739         and then Is_Generic_Instance (S)
1740         and then (Is_Generic_Actual_Type (Dep)
1741                    or else Is_Generic_Actual_Type (Full_View (Dep)))
1742       then
1743          return True;
1744
1745       elsif not (Is_Derived_Type (Dep))
1746         and then Is_Derived_Type (Full_View (Dep))
1747       then
1748          --  When instantiating a package body, the scope stack is empty,
1749          --  so check instead whether the dependent type is defined in
1750          --  the same scope as the instance itself.
1751
1752          return In_Open_Scopes (S)
1753            or else (Is_Generic_Instance (Current_Scope)
1754               and then Scope (Dep) = Scope (Current_Scope));
1755       else
1756          return True;
1757       end if;
1758    end Is_Visible_Dependent;
1759
1760    ----------------------------
1761    -- May_Need_Implicit_Body --
1762    ----------------------------
1763
1764    procedure May_Need_Implicit_Body (E : Entity_Id) is
1765       P     : constant Node_Id := Unit_Declaration_Node (E);
1766       S     : constant Node_Id := Parent (P);
1767       B     : Node_Id;
1768       Decls : List_Id;
1769
1770    begin
1771       if not Has_Completion (E)
1772         and then Nkind (P) = N_Package_Declaration
1773         and then (Present (Activation_Chain_Entity (P)) or else Has_RACW (E))
1774       then
1775          B :=
1776            Make_Package_Body (Sloc (E),
1777              Defining_Unit_Name => Make_Defining_Identifier (Sloc (E),
1778                Chars => Chars (E)),
1779              Declarations  => New_List);
1780
1781          if Nkind (S) = N_Package_Specification then
1782             if Present (Private_Declarations (S)) then
1783                Decls := Private_Declarations (S);
1784             else
1785                Decls := Visible_Declarations (S);
1786             end if;
1787          else
1788             Decls := Declarations (S);
1789          end if;
1790
1791          Append (B, Decls);
1792          Analyze (B);
1793       end if;
1794    end May_Need_Implicit_Body;
1795
1796    ----------------------
1797    -- New_Private_Type --
1798    ----------------------
1799
1800    procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is
1801    begin
1802       Enter_Name (Id);
1803
1804       if Limited_Present (Def) then
1805          Set_Ekind (Id, E_Limited_Private_Type);
1806       else
1807          Set_Ekind (Id, E_Private_Type);
1808       end if;
1809
1810       Set_Etype              (Id, Id);
1811       Set_Has_Delayed_Freeze (Id);
1812       Set_Is_First_Subtype   (Id);
1813       Init_Size_Align        (Id);
1814
1815       Set_Is_Constrained (Id,
1816         No (Discriminant_Specifications (N))
1817           and then not Unknown_Discriminants_Present (N));
1818
1819       --  Set tagged flag before processing discriminants, to catch
1820       --  illegal usage.
1821
1822       Set_Is_Tagged_Type (Id, Tagged_Present (Def));
1823
1824       Set_Discriminant_Constraint (Id, No_Elist);
1825       Set_Stored_Constraint (Id, No_Elist);
1826
1827       if Present (Discriminant_Specifications (N)) then
1828          New_Scope (Id);
1829          Process_Discriminants (N);
1830          End_Scope;
1831
1832       elsif Unknown_Discriminants_Present (N) then
1833          Set_Has_Unknown_Discriminants (Id);
1834       end if;
1835
1836       Set_Private_Dependents (Id, New_Elmt_List);
1837
1838       if Tagged_Present (Def) then
1839          Set_Ekind                (Id, E_Record_Type_With_Private);
1840          Make_Class_Wide_Type     (Id);
1841          Set_Primitive_Operations (Id, New_Elmt_List);
1842          Set_Is_Abstract_Type     (Id, Abstract_Present (Def));
1843          Set_Is_Limited_Record    (Id, Limited_Present (Def));
1844          Set_Has_Delayed_Freeze   (Id, True);
1845
1846       elsif Abstract_Present (Def) then
1847          Error_Msg_N ("only a tagged type can be abstract", N);
1848       end if;
1849    end New_Private_Type;
1850
1851    ----------------------------
1852    -- Uninstall_Declarations --
1853    ----------------------------
1854
1855    procedure Uninstall_Declarations (P : Entity_Id) is
1856       Decl      : constant Node_Id := Unit_Declaration_Node (P);
1857       Id        : Entity_Id;
1858       Full      : Entity_Id;
1859       Priv_Elmt : Elmt_Id;
1860       Priv_Sub  : Entity_Id;
1861
1862       procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
1863       --  Copy to the private declaration the attributes of the full view
1864       --  that need to be available for the partial view also.
1865
1866       function Type_In_Use (T : Entity_Id) return Boolean;
1867       --  Check whether type or base type appear in an active use_type clause
1868
1869       ------------------------------
1870       -- Preserve_Full_Attributes --
1871       ------------------------------
1872
1873       procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
1874          Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
1875
1876       begin
1877          Set_Size_Info (Priv, (Full));
1878          Set_RM_Size                 (Priv, RM_Size (Full));
1879          Set_Size_Known_At_Compile_Time
1880                                      (Priv, Size_Known_At_Compile_Time (Full));
1881          Set_Is_Volatile             (Priv, Is_Volatile                (Full));
1882          Set_Treat_As_Volatile       (Priv, Treat_As_Volatile          (Full));
1883          Set_Is_Ada_2005_Only        (Priv, Is_Ada_2005_Only           (Full));
1884          Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced    (Full));
1885          Set_Has_Pragma_Unreferenced_Objects
1886                                      (Priv, Has_Pragma_Unreferenced_Objects
1887                                                                        (Full));
1888          if Is_Unchecked_Union (Full) then
1889             Set_Is_Unchecked_Union (Base_Type (Priv));
1890          end if;
1891          --  Why is atomic not copied here ???
1892
1893          if Referenced (Full) then
1894             Set_Referenced (Priv);
1895          end if;
1896
1897          if Priv_Is_Base_Type then
1898             Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
1899             Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only
1900                                                            (Base_Type (Full)));
1901             Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
1902             Set_Has_Controlled_Component (Priv, Has_Controlled_Component
1903                                                            (Base_Type (Full)));
1904          end if;
1905
1906          Set_Freeze_Node (Priv, Freeze_Node (Full));
1907
1908          if Is_Tagged_Type (Priv)
1909            and then Is_Tagged_Type (Full)
1910            and then not Error_Posted (Full)
1911          then
1912             if Priv_Is_Base_Type then
1913
1914                --  Ada 2005 (AI-345): The full view of a type implementing
1915                --  an interface can be a task type.
1916
1917                --    type T is new I with private;
1918                --  private
1919                --    task type T is new I with ...
1920
1921                if Is_Interface (Etype (Priv))
1922                  and then Is_Concurrent_Type (Base_Type (Full))
1923                then
1924                   --  Protect the frontend against previous errors
1925
1926                   if Present (Corresponding_Record_Type
1927                                (Base_Type (Full)))
1928                   then
1929                      Set_Access_Disp_Table
1930                        (Priv, Access_Disp_Table
1931                                (Corresponding_Record_Type (Base_Type (Full))));
1932
1933                   --  Generic context, or previous errors
1934
1935                   else
1936                      null;
1937                   end if;
1938
1939                else
1940                   Set_Access_Disp_Table
1941                     (Priv, Access_Disp_Table (Base_Type (Full)));
1942                end if;
1943             end if;
1944
1945             if Is_Tagged_Type (Priv) then
1946
1947                --  If the type is tagged, the tag itself must be available
1948                --  on the partial view, for expansion purposes.
1949
1950                Set_First_Entity (Priv, First_Entity (Full));
1951
1952                --  If there are discriminants in the partial view, these remain
1953                --  visible. Otherwise only the tag itself is visible, and there
1954                --  are no nameable components in the partial view.
1955
1956                if No (Last_Entity (Priv)) then
1957                   Set_Last_Entity (Priv, First_Entity (Priv));
1958                end if;
1959             end if;
1960
1961             Set_Has_Discriminants (Priv, Has_Discriminants (Full));
1962          end if;
1963       end Preserve_Full_Attributes;
1964
1965       -----------------
1966       -- Type_In_Use --
1967       -----------------
1968
1969       function Type_In_Use (T : Entity_Id) return Boolean is
1970       begin
1971          return Scope (Base_Type (T)) = P
1972            and then (In_Use (T) or else In_Use (Base_Type (T)));
1973       end Type_In_Use;
1974
1975    --  Start of processing for Uninstall_Declarations
1976
1977    begin
1978       Id := First_Entity (P);
1979       while Present (Id) and then Id /= First_Private_Entity (P) loop
1980          if Debug_Flag_E then
1981             Write_Str ("unlinking visible entity ");
1982             Write_Int (Int (Id));
1983             Write_Eol;
1984          end if;
1985
1986          --  On  exit from the package scope, we must preserve the visibility
1987          --  established by use clauses in the current scope. Two cases:
1988
1989          --  a) If the entity is an operator, it may be a primitive operator of
1990          --  a type for which there is a visible use-type clause.
1991
1992          --  b) for other entities, their use-visibility is determined by a
1993          --  visible use clause for the package itself. For a generic instance,
1994          --  the instantiation of the formals appears in the visible part,
1995          --  but the formals are private and remain so.
1996
1997          if Ekind (Id) = E_Function
1998            and then  Is_Operator_Symbol_Name (Chars (Id))
1999            and then not Is_Hidden (Id)
2000            and then not Error_Posted (Id)
2001          then
2002             Set_Is_Potentially_Use_Visible (Id,
2003               In_Use (P)
2004               or else Type_In_Use (Etype (Id))
2005               or else Type_In_Use (Etype (First_Formal (Id)))
2006               or else (Present (Next_Formal (First_Formal (Id)))
2007                          and then
2008                            Type_In_Use
2009                              (Etype (Next_Formal (First_Formal (Id))))));
2010          else
2011             Set_Is_Potentially_Use_Visible (Id,
2012               In_Use (P) and not Is_Hidden (Id));
2013          end if;
2014
2015          --  Local entities are not immediately visible outside of the package
2016
2017          Set_Is_Immediately_Visible (Id, False);
2018
2019          --  If this is a private type with a full view (for example a local
2020          --  subtype of a private type declared elsewhere), ensure that the
2021          --  full view is also removed from visibility: it may be exposed when
2022          --  swapping views in an instantiation.
2023
2024          if Is_Type (Id)
2025            and then Present (Full_View (Id))
2026          then
2027             Set_Is_Immediately_Visible (Full_View (Id), False);
2028          end if;
2029
2030          if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
2031             Check_Abstract_Overriding (Id);
2032             Check_Conventions (Id);
2033          end if;
2034
2035          if (Ekind (Id) = E_Private_Type
2036                or else Ekind (Id) = E_Limited_Private_Type)
2037            and then No (Full_View (Id))
2038            and then not Is_Generic_Type (Id)
2039            and then not Is_Derived_Type (Id)
2040          then
2041             Error_Msg_N ("missing full declaration for private type&", Id);
2042
2043          elsif Ekind (Id) = E_Record_Type_With_Private
2044            and then not Is_Generic_Type (Id)
2045            and then No (Full_View (Id))
2046          then
2047             if Nkind (Parent (Id)) = N_Private_Type_Declaration then
2048                Error_Msg_N ("missing full declaration for private type&", Id);
2049             else
2050                Error_Msg_N
2051                  ("missing full declaration for private extension", Id);
2052             end if;
2053
2054          elsif Ekind (Id) = E_Constant
2055            and then No (Constant_Value (Id))
2056            and then No (Full_View (Id))
2057            and then not Is_Imported (Id)
2058            and then (Nkind (Parent (Id)) /= N_Object_Declaration
2059                       or else not No_Initialization (Parent (Id)))
2060          then
2061             if not Has_Private_Declaration (Etype (Id)) then
2062
2063                --  We assume that the user did not not intend a deferred
2064                --  constant declaration, and the expression is just missing.
2065
2066                Error_Msg_N
2067                  ("constant declaration requires initialization expression",
2068                    Parent (Id));
2069
2070                if Is_Limited_Type (Etype (Id)) then
2071                   Error_Msg_N
2072                     ("\if variable intended, remove CONSTANT from declaration",
2073                     Parent (Id));
2074                end if;
2075
2076             else
2077                Error_Msg_N
2078                   ("missing full declaration for deferred constant ('R'M 7.4)",
2079                      Id);
2080
2081                if Is_Limited_Type (Etype (Id)) then
2082                   Error_Msg_N
2083                     ("\if variable intended, remove CONSTANT from declaration",
2084                     Parent (Id));
2085                end if;
2086             end if;
2087          end if;
2088
2089          Next_Entity (Id);
2090       end loop;
2091
2092       --  If the specification was installed as the parent of a public child
2093       --  unit, the private declarations were not installed, and there is
2094       --  nothing to do.
2095
2096       if not In_Private_Part (P) then
2097          return;
2098       else
2099          Set_In_Private_Part (P, False);
2100       end if;
2101
2102       --  Make private entities invisible and exchange full and private
2103       --  declarations for private types.
2104
2105       while Present (Id) loop
2106          if Debug_Flag_E then
2107             Write_Str ("unlinking private entity ");
2108             Write_Int (Int (Id));
2109             Write_Eol;
2110          end if;
2111
2112          if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
2113             Check_Abstract_Overriding (Id);
2114             Check_Conventions (Id);
2115          end if;
2116
2117          Set_Is_Immediately_Visible (Id, False);
2118
2119          if Is_Private_Base_Type (Id)
2120            and then Present (Full_View (Id))
2121          then
2122             Full := Full_View (Id);
2123
2124             --  If the partial view is not declared in the visible part
2125             --  of the package (as is the case when it is a type derived
2126             --  from some other private type in the private part of the
2127             --  current package), no exchange takes place.
2128
2129             if No (Parent (Id))
2130               or else List_Containing (Parent (Id))
2131                 /= Visible_Declarations (Specification (Decl))
2132             then
2133                goto Next_Id;
2134             end if;
2135
2136             --  The entry in the private part points to the full declaration,
2137             --  which is currently visible. Exchange them so only the private
2138             --  type declaration remains accessible, and link private and
2139             --  full declaration in the opposite direction. Before the actual
2140             --  exchange, we copy back attributes of the full view that
2141             --  must be available to the partial view too.
2142
2143             Preserve_Full_Attributes (Id, Full);
2144
2145             Set_Is_Potentially_Use_Visible (Id, In_Use (P));
2146
2147             if  Is_Indefinite_Subtype (Full)
2148               and then not Is_Indefinite_Subtype (Id)
2149             then
2150                Error_Msg_N
2151                  ("full view of type must be definite subtype", Full);
2152             end if;
2153
2154             Priv_Elmt := First_Elmt (Private_Dependents (Id));
2155
2156             --  Swap out the subtypes and derived types of Id that were
2157             --  compiled in this scope, or installed previously by
2158             --  Install_Private_Declarations.
2159             --  Before we do the swap, we verify the presence of the
2160             --  Full_View field which may be empty due to a swap by
2161             --  a previous call to End_Package_Scope (e.g. from the
2162             --  freezing mechanism).
2163
2164             while Present (Priv_Elmt) loop
2165                Priv_Sub := Node (Priv_Elmt);
2166
2167                if Present (Full_View (Priv_Sub)) then
2168
2169                   if Scope (Priv_Sub) = P
2170                      or else not In_Open_Scopes (Scope (Priv_Sub))
2171                   then
2172                      Set_Is_Immediately_Visible (Priv_Sub, False);
2173                   end if;
2174
2175                   if Is_Visible_Dependent (Priv_Sub) then
2176                      Preserve_Full_Attributes
2177                        (Priv_Sub, Full_View (Priv_Sub));
2178                      Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub));
2179                      Exchange_Declarations (Priv_Sub);
2180                   end if;
2181                end if;
2182
2183                Next_Elmt (Priv_Elmt);
2184             end loop;
2185
2186             --  Now restore the type itself to its private view
2187
2188             Exchange_Declarations (Id);
2189
2190          elsif Ekind (Id) = E_Incomplete_Type
2191            and then No (Full_View (Id))
2192          then
2193             --  Mark Taft amendment types
2194
2195             Set_Has_Completion_In_Body (Id);
2196
2197          elsif not Is_Child_Unit (Id)
2198            and then (not Is_Private_Type (Id)
2199                       or else No (Full_View (Id)))
2200          then
2201             Set_Is_Hidden (Id);
2202             Set_Is_Potentially_Use_Visible (Id, False);
2203          end if;
2204
2205          <<Next_Id>>
2206             Next_Entity (Id);
2207       end loop;
2208    end Uninstall_Declarations;
2209
2210    ------------------------
2211    -- Unit_Requires_Body --
2212    ------------------------
2213
2214    function Unit_Requires_Body (P : Entity_Id) return Boolean is
2215       E : Entity_Id;
2216
2217    begin
2218       --  Imported entity never requires body. Right now, only
2219       --  subprograms can be imported, but perhaps in the future
2220       --  we will allow import of packages.
2221
2222       if Is_Imported (P) then
2223          return False;
2224
2225       --  Body required if library package with pragma Elaborate_Body
2226
2227       elsif Has_Pragma_Elaborate_Body (P) then
2228          return True;
2229
2230       --  Body required if subprogram
2231
2232       elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
2233          return True;
2234
2235       --  Treat a block as requiring a body
2236
2237       elsif Ekind (P) = E_Block then
2238          return True;
2239
2240       elsif Ekind (P) = E_Package
2241         and then Nkind (Parent (P)) = N_Package_Specification
2242         and then Present (Generic_Parent (Parent (P)))
2243       then
2244          declare
2245             G_P : constant Entity_Id := Generic_Parent (Parent (P));
2246          begin
2247             if Has_Pragma_Elaborate_Body (G_P) then
2248                return True;
2249             end if;
2250          end;
2251       end if;
2252
2253       --  Otherwise search entity chain for entity requiring completion
2254
2255       E := First_Entity (P);
2256       while Present (E) loop
2257
2258          --  Always ignore child units. Child units get added to the entity
2259          --  list of a parent unit, but are not original entities of the
2260          --  parent, and so do not affect whether the parent needs a body.
2261
2262          if Is_Child_Unit (E) then
2263             null;
2264
2265          --  Ignore formal packages and their renamings
2266
2267          elsif Ekind (E) = E_Package
2268            and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
2269                                                 N_Formal_Package_Declaration
2270          then
2271             null;
2272
2273          --  Otherwise test to see if entity requires a completion.
2274          --  Note that subprogram entities whose declaration does not come
2275          --  from source are ignored here on the basis that we assume the
2276          --  expander will provide an implicit completion at some point.
2277
2278          elsif (Is_Overloadable (E)
2279                and then Ekind (E) /= E_Enumeration_Literal
2280                and then Ekind (E) /= E_Operator
2281                and then not Is_Abstract_Subprogram (E)
2282                and then not Has_Completion (E)
2283                and then Comes_From_Source (Parent (E)))
2284
2285            or else
2286              (Ekind (E) = E_Package
2287                and then E /= P
2288                and then not Has_Completion (E)
2289                and then Unit_Requires_Body (E))
2290
2291            or else
2292              (Ekind (E) = E_Incomplete_Type and then No (Full_View (E)))
2293
2294            or else
2295             ((Ekind (E) = E_Task_Type or else
2296               Ekind (E) = E_Protected_Type)
2297                and then not Has_Completion (E))
2298
2299            or else
2300              (Ekind (E) = E_Generic_Package and then E /= P
2301                and then not Has_Completion (E)
2302                and then Unit_Requires_Body (E))
2303
2304            or else
2305              (Is_Generic_Subprogram (E)
2306                and then not Has_Completion (E))
2307
2308          then
2309             return True;
2310
2311          --  Entity that does not require completion
2312
2313          else
2314             null;
2315          end if;
2316
2317          Next_Entity (E);
2318       end loop;
2319
2320       return False;
2321    end Unit_Requires_Body;
2322
2323 end Sem_Ch7;