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-2007, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  This package contains the routines to process package specifications and
  27 --  bodies. The most important semantic aspects of package processing are the
  28 --  handling of private and full declarations, and the construction of
  29 --  dispatch tables for tagged types.
  30
  31 with Atree;    use Atree;
  32 with Debug;    use Debug;
  33 with Einfo;    use Einfo;
  34 with Elists;   use Elists;
  35 with Errout;   use Errout;
  36 with Exp_Disp; use Exp_Disp;
  37 with Exp_Dist; use Exp_Dist;
  38 with Exp_Dbug; use Exp_Dbug;
  39 with Lib;      use Lib;
  40 with Lib.Xref; use Lib.Xref;
  41 with Namet;    use Namet;
  42 with Nmake;    use Nmake;
  43 with Nlists;   use Nlists;
  44 with Opt;      use Opt;
  45 with Output;   use Output;
  46 with Sem;      use Sem;
  47 with Sem_Cat;  use Sem_Cat;
  48 with Sem_Ch3;  use Sem_Ch3;
  49 with Sem_Ch6;  use Sem_Ch6;
  50 with Sem_Ch8;  use Sem_Ch8;
  51 with Sem_Ch10; use Sem_Ch10;
  52 with Sem_Ch12; use Sem_Ch12;
  53 with Sem_Disp; use Sem_Disp;
  54 with Sem_Util; use Sem_Util;
  55 with Sem_Warn; use Sem_Warn;
  56 with Snames;   use Snames;
  57 with Stand;    use Stand;
  58 with Sinfo;    use Sinfo;
  59 with Sinput;   use Sinput;
  60 with Style;
  61 with Uintp;    use Uintp;
  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       Push_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       Push_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. This is not done for
1103          --  nested instantiations, where the private with_clauses of the
1104          --  enclosing unit have no effect once the instantiation info is
1105          --  established and we start analyzing the package declaration.
1106
1107          declare
1108             Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
1109          begin
1110             if (Ekind (Comp_Unit) = E_Package
1111                  or else Ekind (Comp_Unit) = E_Generic_Package)
1112               and then not In_Private_Part (Comp_Unit)
1113               and then not In_Instance
1114             then
1115                Install_Private_With_Clauses (Comp_Unit);
1116                Private_With_Clauses_Installed := True;
1117             end if;
1118          end;
1119       end if;
1120
1121       --  If this is a package associated with a generic instance or formal
1122       --  package, then the private declarations of each of the generic's
1123       --  parents must be installed at this point.
1124
1125       if Is_Generic_Instance (Id) then
1126          Install_Parent_Private_Declarations (Id);
1127       end if;
1128
1129       --  Analyze private part if present. The flag In_Private_Part is reset
1130       --  in End_Package_Scope.
1131
1132       L := Last_Entity (Id);
1133
1134       if Present (Priv_Decls) then
1135          Set_In_Private_Part (Id);
1136
1137          --  Upon entering a public child's private part, it may be necessary
1138          --  to declare subprograms that were derived in the package's visible
1139          --  part but not yet made visible.
1140
1141          if Public_Child then
1142             Declare_Inherited_Private_Subprograms (Id);
1143          end if;
1144
1145          Analyze_Declarations (Priv_Decls);
1146
1147          --  Check the private declarations for incomplete deferred constants
1148
1149          Inspect_Deferred_Constant_Completion (Priv_Decls);
1150
1151          --  The first private entity is the immediate follower of the last
1152          --  visible entity, if there was one.
1153
1154          if Present (L) then
1155             Set_First_Private_Entity (Id, Next_Entity (L));
1156          else
1157             Set_First_Private_Entity (Id, First_Entity (Id));
1158          end if;
1159
1160       --  There may be inherited private subprograms that need to be declared,
1161       --  even in the absence of an explicit private part.  If there are any
1162       --  public declarations in the package and the package is a public child
1163       --  unit, then an implicit private part is assumed.
1164
1165       elsif Present (L) and then Public_Child then
1166          Set_In_Private_Part (Id);
1167          Declare_Inherited_Private_Subprograms (Id);
1168          Set_First_Private_Entity (Id, Next_Entity (L));
1169       end if;
1170
1171       --  Check rule of 3.6(11), which in general requires waiting till all
1172       --  full types have been seen.
1173
1174       E := First_Entity (Id);
1175       while Present (E) loop
1176          if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then
1177             Check_Aliased_Component_Types (E);
1178          end if;
1179
1180          Next_Entity (E);
1181       end loop;
1182
1183       --  Ada 2005 (AI-216): The completion of an incomplete or private type
1184       --  declaration having a known_discriminant_part shall not be an
1185       --  Unchecked_Union type.
1186
1187       if Present (Vis_Decls) then
1188          Inspect_Unchecked_Union_Completion (Vis_Decls);
1189       end if;
1190
1191       if Present (Priv_Decls) then
1192          Inspect_Unchecked_Union_Completion (Priv_Decls);
1193       end if;
1194
1195       if Ekind (Id) = E_Generic_Package
1196         and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
1197         and then Present (Priv_Decls)
1198       then
1199          --  Save global references in private declarations, ignoring the
1200          --  visible declarations that were processed earlier.
1201
1202          declare
1203             Orig_Spec : constant Node_Id := Specification (Orig_Decl);
1204             Save_Vis  : constant List_Id := Visible_Declarations (Orig_Spec);
1205             Save_Form : constant List_Id :=
1206                           Generic_Formal_Declarations (Orig_Decl);
1207
1208          begin
1209             Set_Visible_Declarations        (Orig_Spec, Empty_List);
1210             Set_Generic_Formal_Declarations (Orig_Decl, Empty_List);
1211             Save_Global_References          (Orig_Decl);
1212             Set_Generic_Formal_Declarations (Orig_Decl, Save_Form);
1213             Set_Visible_Declarations        (Orig_Spec, Save_Vis);
1214          end;
1215       end if;
1216
1217       Process_End_Label (N, 'e', Id);
1218
1219       --  Remove private_with_clauses of enclosing compilation unit, if they
1220       --  were installed.
1221
1222       if Private_With_Clauses_Installed then
1223          Remove_Private_With_Clauses (Cunit (Current_Sem_Unit));
1224       end if;
1225
1226       --  For the case of a library level package, we must go through all the
1227       --  entities clearing the indications that the value may be constant and
1228       --  not modified. Why? Because any client of this package may modify
1229       --  these values freely from anywhere. This also applies to any nested
1230       --  packages or generic packages.
1231
1232       --  For now we unconditionally clear constants for packages that are
1233       --  instances of generic packages. The reason is that we do not have the
1234       --  body yet, and we otherwise think things are unreferenced when they
1235       --  are not. This should be fixed sometime (the effect is not terrible,
1236       --  we just lose some warnings, and also some cases of value propagation)
1237       --  ???
1238
1239       if Is_Library_Level_Entity (Id)
1240         or else Is_Generic_Instance (Id)
1241       then
1242          Clear_Constants (Id, First_Entity (Id));
1243          Clear_Constants (Id, First_Private_Entity (Id));
1244       end if;
1245    end Analyze_Package_Specification;
1246
1247    --------------------------------------
1248    -- Analyze_Private_Type_Declaration --
1249    --------------------------------------
1250
1251    procedure Analyze_Private_Type_Declaration (N : Node_Id) is
1252       PF : constant Boolean   := Is_Pure (Enclosing_Lib_Unit_Entity);
1253       Id : constant Entity_Id := Defining_Identifier (N);
1254
1255    begin
1256       Generate_Definition (Id);
1257       Set_Is_Pure         (Id, PF);
1258       Init_Size_Align     (Id);
1259
1260       if (Ekind (Current_Scope) /= E_Package
1261           and then Ekind (Current_Scope) /= E_Generic_Package)
1262         or else In_Private_Part (Current_Scope)
1263       then
1264          Error_Msg_N ("invalid context for private declaration", N);
1265       end if;
1266
1267       New_Private_Type (N, Id, N);
1268       Set_Depends_On_Private (Id);
1269    end Analyze_Private_Type_Declaration;
1270
1271    ----------------------------------
1272    -- Check_Anonymous_Access_Types --
1273    ----------------------------------
1274
1275    procedure Check_Anonymous_Access_Types
1276      (Spec_Id : Entity_Id;
1277       P_Body  : Node_Id)
1278    is
1279       E  : Entity_Id;
1280       IR : Node_Id;
1281
1282    begin
1283       --  Itype references are only needed by gigi, to force elaboration of
1284       --  itypes. In the absence of code generation, they are not needed.
1285
1286       if not Expander_Active then
1287          return;
1288       end if;
1289
1290       E := First_Entity (Spec_Id);
1291       while Present (E) loop
1292          if Ekind (E) = E_Anonymous_Access_Type
1293            and then From_With_Type (E)
1294          then
1295             IR := Make_Itype_Reference (Sloc (P_Body));
1296             Set_Itype (IR, E);
1297
1298             if No (Declarations (P_Body)) then
1299                Set_Declarations (P_Body, New_List (IR));
1300             else
1301                Prepend (IR, Declarations (P_Body));
1302             end if;
1303          end if;
1304
1305          Next_Entity (E);
1306       end loop;
1307    end Check_Anonymous_Access_Types;
1308
1309    -------------------------------------------
1310    -- Declare_Inherited_Private_Subprograms --
1311    -------------------------------------------
1312
1313    procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
1314
1315       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
1316       --  Check whether an inherited subprogram is an operation of an
1317       --  untagged derived type.
1318
1319       ---------------------
1320       -- Is_Primitive_Of --
1321       ---------------------
1322
1323       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is
1324          Formal : Entity_Id;
1325
1326       begin
1327          if Etype (S) = T then
1328             return True;
1329
1330          else
1331             Formal := First_Formal (S);
1332             while Present (Formal) loop
1333                if Etype (Formal) = T then
1334                   return True;
1335                end if;
1336
1337                Next_Formal (Formal);
1338             end loop;
1339
1340             return False;
1341          end if;
1342       end Is_Primitive_Of;
1343
1344       --  Local variables
1345
1346       E           : Entity_Id;
1347       Op_List     : Elist_Id;
1348       Op_Elmt     : Elmt_Id;
1349       Op_Elmt_2   : Elmt_Id;
1350       Prim_Op     : Entity_Id;
1351       New_Op      : Entity_Id := Empty;
1352       Parent_Subp : Entity_Id;
1353       Tag         : Entity_Id;
1354
1355    --  Start of processing for Declare_Inherited_Private_Subprograms
1356
1357    begin
1358       E := First_Entity (Id);
1359       while Present (E) loop
1360
1361          --  If the entity is a nonprivate type extension whose parent
1362          --  type is declared in an open scope, then the type may have
1363          --  inherited operations that now need to be made visible.
1364          --  Ditto if the entity is a formal derived type in a child unit.
1365
1366          if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
1367                or else
1368                  (Nkind (Parent (E)) = N_Private_Extension_Declaration
1369                    and then Is_Generic_Type (E)))
1370            and then In_Open_Scopes (Scope (Etype (E)))
1371            and then E = Base_Type (E)
1372          then
1373             if Is_Tagged_Type (E) then
1374                Op_List := Primitive_Operations (E);
1375                New_Op  := Empty;
1376                Tag     := First_Tag_Component (E);
1377
1378                Op_Elmt := First_Elmt (Op_List);
1379                while Present (Op_Elmt) loop
1380                   Prim_Op := Node (Op_Elmt);
1381
1382                   --  Search primitives that are implicit operations with an
1383                   --  internal name whose parent operation has a normal name.
1384
1385                   if Present (Alias (Prim_Op))
1386                     and then Find_Dispatching_Type (Alias (Prim_Op)) /= E
1387                     and then not Comes_From_Source (Prim_Op)
1388                     and then Is_Internal_Name (Chars (Prim_Op))
1389                     and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
1390                   then
1391                      Parent_Subp := Alias (Prim_Op);
1392
1393                      --  Case 1: Check if the type has also an explicit
1394                      --  overriding for this primitive.
1395
1396                      Op_Elmt_2 := Next_Elmt (Op_Elmt);
1397                      while Present (Op_Elmt_2) loop
1398                         if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
1399                           and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
1400                         then
1401                            --  The private inherited operation has been
1402                            --  overridden by an explicit subprogram: replace
1403                            --  the former by the latter.
1404
1405                            New_Op := Node (Op_Elmt_2);
1406                            Replace_Elmt (Op_Elmt, New_Op);
1407                            Remove_Elmt  (Op_List, Op_Elmt_2);
1408                            Set_Is_Overriding_Operation (New_Op);
1409
1410                            --  We don't need to inherit its dispatching slot.
1411                            --  Set_All_DT_Position has previously ensured that
1412                            --  the same slot was assigned to the two primitives
1413
1414                            if Present (Tag)
1415                              and then Present (DTC_Entity (New_Op))
1416                              and then Present (DTC_Entity (Prim_Op))
1417                            then
1418                               pragma Assert (DT_Position (New_Op)
1419                                               = DT_Position (Prim_Op));
1420                               null;
1421                            end if;
1422
1423                            goto Next_Primitive;
1424                         end if;
1425
1426                         Next_Elmt (Op_Elmt_2);
1427                      end loop;
1428
1429                      --   Case 2: We have not found any explicit overriding and
1430                      --   hence we need to declare the operation (i.e., make it
1431                      --   visible).
1432
1433                      Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
1434
1435                      --  Inherit the dispatching slot if E is already frozen
1436
1437                      if Is_Frozen (E)
1438                        and then Present (DTC_Entity (Alias (Prim_Op)))
1439                      then
1440                         Set_DTC_Entity_Value (E, New_Op);
1441                         Set_DT_Position (New_Op,
1442                           DT_Position (Alias (Prim_Op)));
1443                      end if;
1444
1445                      pragma Assert
1446                        (Is_Dispatching_Operation (New_Op)
1447                          and then Node (Last_Elmt (Op_List)) = New_Op);
1448
1449                      --  Substitute the new operation for the old one
1450                      --  in the type's primitive operations list. Since
1451                      --  the new operation was also just added to the end
1452                      --  of list, the last element must be removed.
1453
1454                      --  (Question: is there a simpler way of declaring
1455                      --  the operation, say by just replacing the name
1456                      --  of the earlier operation, reentering it in the
1457                      --  in the symbol table (how?), and marking it as
1458                      --  private???)
1459
1460                      Replace_Elmt (Op_Elmt, New_Op);
1461                      Remove_Last_Elmt (Op_List);
1462                   end if;
1463
1464                   <<Next_Primitive>>
1465                   Next_Elmt (Op_Elmt);
1466                end loop;
1467
1468                --  Generate listing showing the contents of the dispatch table
1469
1470                if Debug_Flag_ZZ then
1471                   Write_DT (E);
1472                end if;
1473
1474             else
1475                --   Non-tagged type, scan forward to locate
1476                --   inherited hidden operations.
1477
1478                Prim_Op := Next_Entity (E);
1479                while Present (Prim_Op) loop
1480                   if Is_Subprogram (Prim_Op)
1481                     and then Present (Alias (Prim_Op))
1482                     and then not Comes_From_Source (Prim_Op)
1483                     and then Is_Internal_Name (Chars (Prim_Op))
1484                     and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
1485                     and then Is_Primitive_Of (E, Prim_Op)
1486                   then
1487                      Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
1488                   end if;
1489
1490                   Next_Entity (Prim_Op);
1491                end loop;
1492             end if;
1493          end if;
1494
1495          Next_Entity (E);
1496       end loop;
1497    end Declare_Inherited_Private_Subprograms;
1498
1499    -----------------------
1500    -- End_Package_Scope --
1501    -----------------------
1502
1503    procedure End_Package_Scope (P : Entity_Id) is
1504    begin
1505       Uninstall_Declarations (P);
1506       Pop_Scope;
1507    end End_Package_Scope;
1508
1509    ---------------------------
1510    -- Exchange_Declarations --
1511    ---------------------------
1512
1513    procedure Exchange_Declarations (Id : Entity_Id) is
1514       Full_Id : constant Entity_Id := Full_View (Id);
1515       H1      : constant Entity_Id := Homonym (Id);
1516       Next1   : constant Entity_Id := Next_Entity (Id);
1517       H2      : Entity_Id;
1518       Next2   : Entity_Id;
1519
1520    begin
1521       --  If missing full declaration for type, nothing to exchange
1522
1523       if No (Full_Id) then
1524          return;
1525       end if;
1526
1527       --  Otherwise complete the exchange, and preserve semantic links
1528
1529       Next2 := Next_Entity (Full_Id);
1530       H2    := Homonym (Full_Id);
1531
1532       --  Reset full declaration pointer to reflect the switched entities
1533       --  and readjust the next entity chains.
1534
1535       Exchange_Entities (Id, Full_Id);
1536
1537       Set_Next_Entity (Id, Next1);
1538       Set_Homonym     (Id, H1);
1539
1540       Set_Full_View   (Full_Id, Id);
1541       Set_Next_Entity (Full_Id, Next2);
1542       Set_Homonym     (Full_Id, H2);
1543    end Exchange_Declarations;
1544
1545    ------------------------------------------
1546    -- Inspect_Deferred_Constant_Completion --
1547    ------------------------------------------
1548
1549    procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
1550       Decl   : Node_Id;
1551
1552    begin
1553       Decl := First (Decls);
1554       while Present (Decl) loop
1555
1556          --  Deferred constant signature
1557
1558          if Nkind (Decl) = N_Object_Declaration
1559            and then Constant_Present (Decl)
1560            and then No (Expression (Decl))
1561
1562             --  No need to check internally generated constants
1563
1564            and then Comes_From_Source (Decl)
1565
1566             --  The constant is not completed. A full object declaration
1567             --  or a pragma Import complete a deferred constant.
1568
1569            and then not Has_Completion (Defining_Identifier (Decl))
1570          then
1571             Error_Msg_N
1572               ("constant declaration requires initialization expression",
1573               Defining_Identifier (Decl));
1574          end if;
1575
1576          Decl := Next (Decl);
1577       end loop;
1578    end Inspect_Deferred_Constant_Completion;
1579
1580    ----------------------------
1581    -- Install_Package_Entity --
1582    ----------------------------
1583
1584    procedure Install_Package_Entity (Id : Entity_Id) is
1585    begin
1586       if not Is_Internal (Id) then
1587          if Debug_Flag_E then
1588             Write_Str ("Install: ");
1589             Write_Name (Chars (Id));
1590             Write_Eol;
1591          end if;
1592
1593          if not Is_Child_Unit (Id) then
1594             Set_Is_Immediately_Visible (Id);
1595          end if;
1596
1597       end if;
1598    end Install_Package_Entity;
1599
1600    ----------------------------------
1601    -- Install_Private_Declarations --
1602    ----------------------------------
1603
1604    procedure Install_Private_Declarations (P : Entity_Id) is
1605       Id        : Entity_Id;
1606       Priv_Elmt : Elmt_Id;
1607       Priv      : Entity_Id;
1608       Full      : Entity_Id;
1609
1610    begin
1611       --  First exchange declarations for private types, so that the
1612       --  full declaration is visible. For each private type, we check
1613       --  its Private_Dependents list and also exchange any subtypes of
1614       --  or derived types from it. Finally, if this is a Taft amendment
1615       --  type, the incomplete declaration is irrelevant, and we want to
1616       --  link the eventual full declaration with the original private
1617       --  one so we also skip the exchange.
1618
1619       Id := First_Entity (P);
1620       while Present (Id) and then Id /= First_Private_Entity (P) loop
1621          if Is_Private_Base_Type (Id)
1622            and then Comes_From_Source (Full_View (Id))
1623            and then Present (Full_View (Id))
1624            and then Scope (Full_View (Id)) = Scope (Id)
1625            and then Ekind (Full_View (Id)) /= E_Incomplete_Type
1626          then
1627             --  If there is a use-type clause on the private type, set the
1628             --  full view accordingly.
1629
1630             Set_In_Use (Full_View (Id), In_Use (Id));
1631             Full := Full_View (Id);
1632
1633             if Is_Private_Base_Type (Full)
1634               and then Has_Private_Declaration (Full)
1635               and then Nkind (Parent (Full)) = N_Full_Type_Declaration
1636               and then In_Open_Scopes (Scope (Etype (Full)))
1637               and then In_Package_Body (Current_Scope)
1638               and then not Is_Private_Type (Etype (Full))
1639             then
1640                --  This is the completion of a private type by a derivation
1641                --  from another private type which is not private anymore. This
1642                --  can only happen in a package nested within a child package,
1643                --  when the parent type is defined in the parent unit. At this
1644                --  point the current type is not private either, and we have to
1645                --  install the underlying full view, which is now visible.
1646
1647                if No (Full_View (Full))
1648                  and then Present (Underlying_Full_View (Full))
1649                then
1650                   Set_Full_View (Id, Underlying_Full_View (Full));
1651                   Set_Underlying_Full_View (Full, Empty);
1652                   Set_Is_Frozen (Full_View (Id));
1653                end if;
1654             end if;
1655
1656             Priv_Elmt := First_Elmt (Private_Dependents (Id));
1657
1658             Exchange_Declarations (Id);
1659             Set_Is_Immediately_Visible (Id);
1660
1661             while Present (Priv_Elmt) loop
1662                Priv := Node (Priv_Elmt);
1663
1664                --  Before the exchange, verify that the presence of the
1665                --  Full_View field. It will be empty if the entity
1666                --  has already been installed due to a previous call.
1667
1668                if Present (Full_View (Priv))
1669                  and then Is_Visible_Dependent (Priv)
1670                then
1671
1672                   --  For each subtype that is swapped, we also swap the
1673                   --  reference to it in Private_Dependents, to allow access
1674                   --  to it when we swap them out in End_Package_Scope.
1675
1676                   Replace_Elmt (Priv_Elmt, Full_View (Priv));
1677                   Exchange_Declarations (Priv);
1678                   Set_Is_Immediately_Visible
1679                     (Priv, In_Open_Scopes (Scope (Priv)));
1680                   Set_Is_Potentially_Use_Visible
1681                     (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
1682                end if;
1683
1684                Next_Elmt (Priv_Elmt);
1685             end loop;
1686          end if;
1687
1688          Next_Entity (Id);
1689       end loop;
1690
1691       --  Next make other declarations in the private part visible as well
1692
1693       Id := First_Private_Entity (P);
1694       while Present (Id) loop
1695          Install_Package_Entity (Id);
1696          Set_Is_Hidden (Id, False);
1697          Next_Entity (Id);
1698       end loop;
1699
1700       --  Indicate that the private part is currently visible, so it can be
1701       --  properly reset on exit.
1702
1703       Set_In_Private_Part (P);
1704    end Install_Private_Declarations;
1705
1706    ----------------------------------
1707    -- Install_Visible_Declarations --
1708    ----------------------------------
1709
1710    procedure Install_Visible_Declarations (P : Entity_Id) is
1711       Id          : Entity_Id;
1712       Last_Entity : Entity_Id;
1713
1714    begin
1715       pragma Assert
1716         (Is_Package_Or_Generic_Package (P) or else Is_Record_Type (P));
1717
1718       if Is_Package_Or_Generic_Package (P) then
1719          Last_Entity := First_Private_Entity (P);
1720       else
1721          Last_Entity := Empty;
1722       end if;
1723
1724       Id := First_Entity (P);
1725       while Present (Id) and then Id /= Last_Entity loop
1726          Install_Package_Entity (Id);
1727          Next_Entity (Id);
1728       end loop;
1729    end Install_Visible_Declarations;
1730
1731    --------------------------
1732    -- Is_Private_Base_Type --
1733    --------------------------
1734
1735    function Is_Private_Base_Type (E : Entity_Id) return Boolean is
1736    begin
1737       return Ekind (E) = E_Private_Type
1738         or else Ekind (E) = E_Limited_Private_Type
1739         or else Ekind (E) = E_Record_Type_With_Private;
1740    end Is_Private_Base_Type;
1741
1742    --------------------------
1743    -- Is_Visible_Dependent --
1744    --------------------------
1745
1746    function Is_Visible_Dependent (Dep : Entity_Id) return Boolean
1747    is
1748       S : constant Entity_Id := Scope (Dep);
1749
1750    begin
1751       --  Renamings created for actual types have the visibility of the
1752       --  actual.
1753
1754       if Ekind (S) = E_Package
1755         and then Is_Generic_Instance (S)
1756         and then (Is_Generic_Actual_Type (Dep)
1757                    or else Is_Generic_Actual_Type (Full_View (Dep)))
1758       then
1759          return True;
1760
1761       elsif not (Is_Derived_Type (Dep))
1762         and then Is_Derived_Type (Full_View (Dep))
1763       then
1764          --  When instantiating a package body, the scope stack is empty,
1765          --  so check instead whether the dependent type is defined in
1766          --  the same scope as the instance itself.
1767
1768          return In_Open_Scopes (S)
1769            or else (Is_Generic_Instance (Current_Scope)
1770               and then Scope (Dep) = Scope (Current_Scope));
1771       else
1772          return True;
1773       end if;
1774    end Is_Visible_Dependent;
1775
1776    ----------------------------
1777    -- May_Need_Implicit_Body --
1778    ----------------------------
1779
1780    procedure May_Need_Implicit_Body (E : Entity_Id) is
1781       P     : constant Node_Id := Unit_Declaration_Node (E);
1782       S     : constant Node_Id := Parent (P);
1783       B     : Node_Id;
1784       Decls : List_Id;
1785
1786    begin
1787       if not Has_Completion (E)
1788         and then Nkind (P) = N_Package_Declaration
1789         and then (Present (Activation_Chain_Entity (P)) or else Has_RACW (E))
1790       then
1791          B :=
1792            Make_Package_Body (Sloc (E),
1793              Defining_Unit_Name => Make_Defining_Identifier (Sloc (E),
1794                Chars => Chars (E)),
1795              Declarations  => New_List);
1796
1797          if Nkind (S) = N_Package_Specification then
1798             if Present (Private_Declarations (S)) then
1799                Decls := Private_Declarations (S);
1800             else
1801                Decls := Visible_Declarations (S);
1802             end if;
1803          else
1804             Decls := Declarations (S);
1805          end if;
1806
1807          Append (B, Decls);
1808          Analyze (B);
1809       end if;
1810    end May_Need_Implicit_Body;
1811
1812    ----------------------
1813    -- New_Private_Type --
1814    ----------------------
1815
1816    procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is
1817    begin
1818       Enter_Name (Id);
1819
1820       if Limited_Present (Def) then
1821          Set_Ekind (Id, E_Limited_Private_Type);
1822       else
1823          Set_Ekind (Id, E_Private_Type);
1824       end if;
1825
1826       Set_Etype              (Id, Id);
1827       Set_Has_Delayed_Freeze (Id);
1828       Set_Is_First_Subtype   (Id);
1829       Init_Size_Align        (Id);
1830
1831       Set_Is_Constrained (Id,
1832         No (Discriminant_Specifications (N))
1833           and then not Unknown_Discriminants_Present (N));
1834
1835       --  Set tagged flag before processing discriminants, to catch
1836       --  illegal usage.
1837
1838       Set_Is_Tagged_Type (Id, Tagged_Present (Def));
1839
1840       Set_Discriminant_Constraint (Id, No_Elist);
1841       Set_Stored_Constraint (Id, No_Elist);
1842
1843       if Present (Discriminant_Specifications (N)) then
1844          Push_Scope (Id);
1845          Process_Discriminants (N);
1846          End_Scope;
1847
1848       elsif Unknown_Discriminants_Present (N) then
1849          Set_Has_Unknown_Discriminants (Id);
1850       end if;
1851
1852       Set_Private_Dependents (Id, New_Elmt_List);
1853
1854       if Tagged_Present (Def) then
1855          Set_Ekind                (Id, E_Record_Type_With_Private);
1856          Make_Class_Wide_Type     (Id);
1857          Set_Primitive_Operations (Id, New_Elmt_List);
1858          Set_Is_Abstract_Type     (Id, Abstract_Present (Def));
1859          Set_Is_Limited_Record    (Id, Limited_Present (Def));
1860          Set_Has_Delayed_Freeze   (Id, True);
1861
1862       elsif Abstract_Present (Def) then
1863          Error_Msg_N ("only a tagged type can be abstract", N);
1864       end if;
1865    end New_Private_Type;
1866
1867    ----------------------------
1868    -- Uninstall_Declarations --
1869    ----------------------------
1870
1871    procedure Uninstall_Declarations (P : Entity_Id) is
1872       Decl      : constant Node_Id := Unit_Declaration_Node (P);
1873       Id        : Entity_Id;
1874       Full      : Entity_Id;
1875       Priv_Elmt : Elmt_Id;
1876       Priv_Sub  : Entity_Id;
1877
1878       procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
1879       --  Copy to the private declaration the attributes of the full view
1880       --  that need to be available for the partial view also.
1881
1882       function Type_In_Use (T : Entity_Id) return Boolean;
1883       --  Check whether type or base type appear in an active use_type clause
1884
1885       ------------------------------
1886       -- Preserve_Full_Attributes --
1887       ------------------------------
1888
1889       procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
1890          Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
1891
1892       begin
1893          Set_Size_Info (Priv, (Full));
1894          Set_RM_Size                 (Priv, RM_Size (Full));
1895          Set_Size_Known_At_Compile_Time
1896                                      (Priv, Size_Known_At_Compile_Time (Full));
1897          Set_Is_Volatile             (Priv, Is_Volatile                (Full));
1898          Set_Treat_As_Volatile       (Priv, Treat_As_Volatile          (Full));
1899          Set_Is_Ada_2005_Only        (Priv, Is_Ada_2005_Only           (Full));
1900          Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced    (Full));
1901          Set_Has_Pragma_Unreferenced_Objects
1902                                      (Priv, Has_Pragma_Unreferenced_Objects
1903                                                                        (Full));
1904          if Is_Unchecked_Union (Full) then
1905             Set_Is_Unchecked_Union (Base_Type (Priv));
1906          end if;
1907          --  Why is atomic not copied here ???
1908
1909          if Referenced (Full) then
1910             Set_Referenced (Priv);
1911          end if;
1912
1913          if Priv_Is_Base_Type then
1914             Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
1915             Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only
1916                                                            (Base_Type (Full)));
1917             Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
1918             Set_Has_Controlled_Component (Priv, Has_Controlled_Component
1919                                                            (Base_Type (Full)));
1920          end if;
1921
1922          Set_Freeze_Node (Priv, Freeze_Node (Full));
1923
1924          if Is_Tagged_Type (Priv)
1925            and then Is_Tagged_Type (Full)
1926            and then not Error_Posted (Full)
1927          then
1928             if Priv_Is_Base_Type then
1929
1930                --  Ada 2005 (AI-345): The full view of a type implementing
1931                --  an interface can be a task type.
1932
1933                --    type T is new I with private;
1934                --  private
1935                --    task type T is new I with ...
1936
1937                if Is_Interface (Etype (Priv))
1938                  and then Is_Concurrent_Type (Base_Type (Full))
1939                then
1940                   --  Protect the frontend against previous errors
1941
1942                   if Present (Corresponding_Record_Type
1943                                (Base_Type (Full)))
1944                   then
1945                      Set_Access_Disp_Table
1946                        (Priv, Access_Disp_Table
1947                                (Corresponding_Record_Type (Base_Type (Full))));
1948
1949                   --  Generic context, or previous errors
1950
1951                   else
1952                      null;
1953                   end if;
1954
1955                else
1956                   Set_Access_Disp_Table
1957                     (Priv, Access_Disp_Table (Base_Type (Full)));
1958                end if;
1959             end if;
1960
1961             if Is_Tagged_Type (Priv) then
1962
1963                --  If the type is tagged, the tag itself must be available
1964                --  on the partial view, for expansion purposes.
1965
1966                Set_First_Entity (Priv, First_Entity (Full));
1967
1968                --  If there are discriminants in the partial view, these remain
1969                --  visible. Otherwise only the tag itself is visible, and there
1970                --  are no nameable components in the partial view.
1971
1972                if No (Last_Entity (Priv)) then
1973                   Set_Last_Entity (Priv, First_Entity (Priv));
1974                end if;
1975             end if;
1976
1977             Set_Has_Discriminants (Priv, Has_Discriminants (Full));
1978          end if;
1979       end Preserve_Full_Attributes;
1980
1981       -----------------
1982       -- Type_In_Use --
1983       -----------------
1984
1985       function Type_In_Use (T : Entity_Id) return Boolean is
1986       begin
1987          return Scope (Base_Type (T)) = P
1988            and then (In_Use (T) or else In_Use (Base_Type (T)));
1989       end Type_In_Use;
1990
1991    --  Start of processing for Uninstall_Declarations
1992
1993    begin
1994       Id := First_Entity (P);
1995       while Present (Id) and then Id /= First_Private_Entity (P) loop
1996          if Debug_Flag_E then
1997             Write_Str ("unlinking visible entity ");
1998             Write_Int (Int (Id));
1999             Write_Eol;
2000          end if;
2001
2002          --  On  exit from the package scope, we must preserve the visibility
2003          --  established by use clauses in the current scope. Two cases:
2004
2005          --  a) If the entity is an operator, it may be a primitive operator of
2006          --  a type for which there is a visible use-type clause.
2007
2008          --  b) for other entities, their use-visibility is determined by a
2009          --  visible use clause for the package itself. For a generic instance,
2010          --  the instantiation of the formals appears in the visible part,
2011          --  but the formals are private and remain so.
2012
2013          if Ekind (Id) = E_Function
2014            and then  Is_Operator_Symbol_Name (Chars (Id))
2015            and then not Is_Hidden (Id)
2016            and then not Error_Posted (Id)
2017          then
2018             Set_Is_Potentially_Use_Visible (Id,
2019               In_Use (P)
2020               or else Type_In_Use (Etype (Id))
2021               or else Type_In_Use (Etype (First_Formal (Id)))
2022               or else (Present (Next_Formal (First_Formal (Id)))
2023                          and then
2024                            Type_In_Use
2025                              (Etype (Next_Formal (First_Formal (Id))))));
2026          else
2027             Set_Is_Potentially_Use_Visible (Id,
2028               In_Use (P) and not Is_Hidden (Id));
2029          end if;
2030
2031          --  Local entities are not immediately visible outside of the package
2032
2033          Set_Is_Immediately_Visible (Id, False);
2034
2035          --  If this is a private type with a full view (for example a local
2036          --  subtype of a private type declared elsewhere), ensure that the
2037          --  full view is also removed from visibility: it may be exposed when
2038          --  swapping views in an instantiation.
2039
2040          if Is_Type (Id)
2041            and then Present (Full_View (Id))
2042          then
2043             Set_Is_Immediately_Visible (Full_View (Id), False);
2044          end if;
2045
2046          if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
2047             Check_Abstract_Overriding (Id);
2048             Check_Conventions (Id);
2049          end if;
2050
2051          if (Ekind (Id) = E_Private_Type
2052                or else Ekind (Id) = E_Limited_Private_Type)
2053            and then No (Full_View (Id))
2054            and then not Is_Generic_Type (Id)
2055            and then not Is_Derived_Type (Id)
2056          then
2057             Error_Msg_N ("missing full declaration for private type&", Id);
2058
2059          elsif Ekind (Id) = E_Record_Type_With_Private
2060            and then not Is_Generic_Type (Id)
2061            and then No (Full_View (Id))
2062          then
2063             if Nkind (Parent (Id)) = N_Private_Type_Declaration then
2064                Error_Msg_N ("missing full declaration for private type&", Id);
2065             else
2066                Error_Msg_N
2067                  ("missing full declaration for private extension", Id);
2068             end if;
2069
2070          elsif Ekind (Id) = E_Constant
2071            and then No (Constant_Value (Id))
2072            and then No (Full_View (Id))
2073            and then not Is_Imported (Id)
2074            and then (Nkind (Parent (Id)) /= N_Object_Declaration
2075                       or else not No_Initialization (Parent (Id)))
2076          then
2077             if not Has_Private_Declaration (Etype (Id)) then
2078
2079                --  We assume that the user did not not intend a deferred
2080                --  constant declaration, and the expression is just missing.
2081
2082                Error_Msg_N
2083                  ("constant declaration requires initialization expression",
2084                    Parent (Id));
2085
2086                if Is_Limited_Type (Etype (Id)) then
2087                   Error_Msg_N
2088                     ("\if variable intended, remove CONSTANT from declaration",
2089                     Parent (Id));
2090                end if;
2091
2092             else
2093                Error_Msg_N
2094                   ("missing full declaration for deferred constant (RM 7.4)",
2095                      Id);
2096
2097                if Is_Limited_Type (Etype (Id)) then
2098                   Error_Msg_N
2099                     ("\if variable intended, remove CONSTANT from declaration",
2100                     Parent (Id));
2101                end if;
2102             end if;
2103          end if;
2104
2105          Next_Entity (Id);
2106       end loop;
2107
2108       --  If the specification was installed as the parent of a public child
2109       --  unit, the private declarations were not installed, and there is
2110       --  nothing to do.
2111
2112       if not In_Private_Part (P) then
2113          return;
2114       else
2115          Set_In_Private_Part (P, False);
2116       end if;
2117
2118       --  Make private entities invisible and exchange full and private
2119       --  declarations for private types.
2120
2121       while Present (Id) loop
2122          if Debug_Flag_E then
2123             Write_Str ("unlinking private entity ");
2124             Write_Int (Int (Id));
2125             Write_Eol;
2126          end if;
2127
2128          if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
2129             Check_Abstract_Overriding (Id);
2130             Check_Conventions (Id);
2131          end if;
2132
2133          Set_Is_Immediately_Visible (Id, False);
2134
2135          if Is_Private_Base_Type (Id)
2136            and then Present (Full_View (Id))
2137          then
2138             Full := Full_View (Id);
2139
2140             --  If the partial view is not declared in the visible part
2141             --  of the package (as is the case when it is a type derived
2142             --  from some other private type in the private part of the
2143             --  current package), no exchange takes place.
2144
2145             if No (Parent (Id))
2146               or else List_Containing (Parent (Id))
2147                 /= Visible_Declarations (Specification (Decl))
2148             then
2149                goto Next_Id;
2150             end if;
2151
2152             --  The entry in the private part points to the full declaration,
2153             --  which is currently visible. Exchange them so only the private
2154             --  type declaration remains accessible, and link private and
2155             --  full declaration in the opposite direction. Before the actual
2156             --  exchange, we copy back attributes of the full view that
2157             --  must be available to the partial view too.
2158
2159             Preserve_Full_Attributes (Id, Full);
2160
2161             Set_Is_Potentially_Use_Visible (Id, In_Use (P));
2162
2163             if  Is_Indefinite_Subtype (Full)
2164               and then not Is_Indefinite_Subtype (Id)
2165             then
2166                Error_Msg_N
2167                  ("full view of type must be definite subtype", Full);
2168             end if;
2169
2170             Priv_Elmt := First_Elmt (Private_Dependents (Id));
2171
2172             --  Swap out the subtypes and derived types of Id that were
2173             --  compiled in this scope, or installed previously by
2174             --  Install_Private_Declarations.
2175             --  Before we do the swap, we verify the presence of the
2176             --  Full_View field which may be empty due to a swap by
2177             --  a previous call to End_Package_Scope (e.g. from the
2178             --  freezing mechanism).
2179
2180             while Present (Priv_Elmt) loop
2181                Priv_Sub := Node (Priv_Elmt);
2182
2183                if Present (Full_View (Priv_Sub)) then
2184
2185                   if Scope (Priv_Sub) = P
2186                      or else not In_Open_Scopes (Scope (Priv_Sub))
2187                   then
2188                      Set_Is_Immediately_Visible (Priv_Sub, False);
2189                   end if;
2190
2191                   if Is_Visible_Dependent (Priv_Sub) then
2192                      Preserve_Full_Attributes
2193                        (Priv_Sub, Full_View (Priv_Sub));
2194                      Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub));
2195                      Exchange_Declarations (Priv_Sub);
2196                   end if;
2197                end if;
2198
2199                Next_Elmt (Priv_Elmt);
2200             end loop;
2201
2202             --  Now restore the type itself to its private view
2203
2204             Exchange_Declarations (Id);
2205
2206          elsif Ekind (Id) = E_Incomplete_Type
2207            and then No (Full_View (Id))
2208          then
2209             --  Mark Taft amendment types
2210
2211             Set_Has_Completion_In_Body (Id);
2212
2213          elsif not Is_Child_Unit (Id)
2214            and then (not Is_Private_Type (Id)
2215                       or else No (Full_View (Id)))
2216          then
2217             Set_Is_Hidden (Id);
2218             Set_Is_Potentially_Use_Visible (Id, False);
2219          end if;
2220
2221          <<Next_Id>>
2222             Next_Entity (Id);
2223       end loop;
2224    end Uninstall_Declarations;
2225
2226    ------------------------
2227    -- Unit_Requires_Body --
2228    ------------------------
2229
2230    function Unit_Requires_Body (P : Entity_Id) return Boolean is
2231       E : Entity_Id;
2232
2233    begin
2234       --  Imported entity never requires body. Right now, only
2235       --  subprograms can be imported, but perhaps in the future
2236       --  we will allow import of packages.
2237
2238       if Is_Imported (P) then
2239          return False;
2240
2241       --  Body required if library package with pragma Elaborate_Body
2242
2243       elsif Has_Pragma_Elaborate_Body (P) then
2244          return True;
2245
2246       --  Body required if subprogram
2247
2248       elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
2249          return True;
2250
2251       --  Treat a block as requiring a body
2252
2253       elsif Ekind (P) = E_Block then
2254          return True;
2255
2256       elsif Ekind (P) = E_Package
2257         and then Nkind (Parent (P)) = N_Package_Specification
2258         and then Present (Generic_Parent (Parent (P)))
2259       then
2260          declare
2261             G_P : constant Entity_Id := Generic_Parent (Parent (P));
2262          begin
2263             if Has_Pragma_Elaborate_Body (G_P) then
2264                return True;
2265             end if;
2266          end;
2267       end if;
2268
2269       --  Otherwise search entity chain for entity requiring completion
2270
2271       E := First_Entity (P);
2272       while Present (E) loop
2273
2274          --  Always ignore child units. Child units get added to the entity
2275          --  list of a parent unit, but are not original entities of the
2276          --  parent, and so do not affect whether the parent needs a body.
2277
2278          if Is_Child_Unit (E) then
2279             null;
2280
2281          --  Ignore formal packages and their renamings
2282
2283          elsif Ekind (E) = E_Package
2284            and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
2285                                                 N_Formal_Package_Declaration
2286          then
2287             null;
2288
2289          --  Otherwise test to see if entity requires a completion.
2290          --  Note that subprogram entities whose declaration does not come
2291          --  from source are ignored here on the basis that we assume the
2292          --  expander will provide an implicit completion at some point.
2293
2294          elsif (Is_Overloadable (E)
2295                and then Ekind (E) /= E_Enumeration_Literal
2296                and then Ekind (E) /= E_Operator
2297                and then not Is_Abstract_Subprogram (E)
2298                and then not Has_Completion (E)
2299                and then Comes_From_Source (Parent (E)))
2300
2301            or else
2302              (Ekind (E) = E_Package
2303                and then E /= P
2304                and then not Has_Completion (E)
2305                and then Unit_Requires_Body (E))
2306
2307            or else
2308              (Ekind (E) = E_Incomplete_Type and then No (Full_View (E)))
2309
2310            or else
2311             ((Ekind (E) = E_Task_Type or else
2312               Ekind (E) = E_Protected_Type)
2313                and then not Has_Completion (E))
2314
2315            or else
2316              (Ekind (E) = E_Generic_Package and then E /= P
2317                and then not Has_Completion (E)
2318                and then Unit_Requires_Body (E))
2319
2320            or else
2321              (Is_Generic_Subprogram (E)
2322                and then not Has_Completion (E))
2323
2324          then
2325             return True;
2326
2327          --  Entity that does not require completion
2328
2329          else
2330             null;
2331          end if;
2332
2333          Next_Entity (E);
2334       end loop;
2335
2336       return False;
2337    end Unit_Requires_Body;
2338
2339 end Sem_Ch7;