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