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 --                                                                          --
  10 --          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 --  This package contains the routines to process package specifications and
  29 --  bodies. The most important semantic aspects of package processing are the
  30 --  handling of private and full declarations, and the construction of
  31 --  dispatch tables for tagged types.
  32
  33 with Atree;    use Atree;
  34 with Debug;    use Debug;
  35 with Einfo;    use Einfo;
  36 with Elists;   use Elists;
  37 with Errout;   use Errout;
  38 with Exp_Disp; use Exp_Disp;
  39 with Exp_Dbug; use Exp_Dbug;
  40 with Lib;      use Lib;
  41 with Lib.Xref; use Lib.Xref;
  42 with Namet;    use Namet;
  43 with Nmake;    use Nmake;
  44 with Nlists;   use Nlists;
  45 with Opt;      use Opt;
  46 with Output;   use Output;
  47 with Sem;      use Sem;
  48 with Sem_Cat;  use Sem_Cat;
  49 with Sem_Ch3;  use Sem_Ch3;
  50 with Sem_Ch6;  use Sem_Ch6;
  51 with Sem_Ch8;  use Sem_Ch8;
  52 with Sem_Ch12; use Sem_Ch12;
  53 with Sem_Util; use Sem_Util;
  54 with Sem_Warn; use Sem_Warn;
  55 with Snames;   use Snames;
  56 with Stand;    use Stand;
  57 with Sinfo;    use Sinfo;
  58 with Sinput;   use Sinput;
  59 with Style;
  60
  61 package body Sem_Ch7 is
  62
  63    -----------------------------------
  64    -- Handling private declarations --
  65    -----------------------------------
  66
  67    --  The principle that each entity has a single defining occurrence clashes
  68    --  with the presence of two separate definitions for private types: the
  69    --  first is the private type declaration, and the second is the full type
  70    --  declaration. It is important that all references to the type point to
  71    --  the same defining occurrence, namely the first one. To enforce the two
  72    --  separate views of the entity, the corresponding information is swapped
  73    --  between the two declarations. Outside of the package, the defining
  74    --  occurrence only contains the private declaration information, while in
  75    --  the private part and the body of the package the defining occurrence
  76    --  contains the full declaration. To simplify the swap, the defining
  77    --  occurrence that currently holds the private declaration points to the
  78    --  full declaration. During semantic processing the defining occurrence
  79    --  also points to a list of private dependents, that is to say access types
  80    --  or composite types whose designated types or component types are
  81    --  subtypes or derived types of the private type in question. After the
  82    --  full declaration has been seen, the private dependents are updated to
  83    --  indicate that they have full definitions.
  84
  85    -----------------------
  86    -- Local Subprograms --
  87    -----------------------
  88
  89    procedure Install_Composite_Operations (P : Entity_Id);
  90    --  Composite types declared in the current scope may depend on
  91    --  types that were private at the point of declaration, and whose
  92    --  full view is now in  scope. Indicate that the corresponding
  93    --  operations on the composite type are available.
  94
  95    function Is_Private_Base_Type (E : Entity_Id) return Boolean;
  96    --  True for a private type that is not a subtype.
  97
  98    function Is_Visible_Dependent (Dep : Entity_Id) return Boolean;
  99    --  If the private dependent is a private type whose full view is
 100    --  derived from the parent type, its full properties are revealed
 101    --  only if we are in the immediate scope of the private dependent.
 102    --  Should this predicate be tightened further???
 103
 104    procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
 105    --  Copy to the private declaration the attributes of the full view
 106    --  that need to be available for the partial view also.
 107
 108    procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id);
 109    --  Called upon entering the private part of a public child package
 110    --  and the body of a nested package, to potentially declare certain
 111    --  inherited subprograms that were inherited by types in the visible
 112    --  part, but whose declaration was deferred because the parent
 113    --  operation was private and not visible at that point. These
 114    --  subprograms are located by traversing the visible part declarations
 115    --  looking for nonprivate type extensions and then examining each of
 116    --  the primitive operations of such types to find those that were
 117    --  inherited but declared with a special internal name. Each such
 118    --  operation is now declared as an operation with a normal name (using
 119    --  the name of the parent operation) and replaces the previous implicit
 120    --  operation in the primitive operations list of the type. If the
 121    --  inherited private operation has been overridden, then it's
 122    --  replaced by the overriding operation.
 123
 124    --------------------------
 125    -- Analyze_Package_Body --
 126    --------------------------
 127
 128    procedure Analyze_Package_Body (N : Node_Id) is
 129       Loc              : constant Source_Ptr := Sloc (N);
 130       HSS              : Node_Id;
 131       Body_Id          : Entity_Id;
 132       Spec_Id          : Entity_Id;
 133       Last_Spec_Entity : Entity_Id;
 134       New_N            : Node_Id;
 135       Pack_Decl        : Node_Id;
 136
 137    begin
 138       --  Find corresponding package specification, and establish the
 139       --  current scope. The visible defining entity for the package is the
 140       --  defining occurrence in the spec. On exit from the package body, all
 141       --  body declarations are attached to the defining entity for the body,
 142       --  but the later is never used for name resolution. In this fashion
 143       --  there is only one visible entity that denotes the package.
 144
 145       if Debug_Flag_C then
 146          Write_Str ("====  Compiling package body ");
 147          Write_Name (Chars (Defining_Entity (N)));
 148          Write_Str (" from ");
 149          Write_Location (Loc);
 150          Write_Eol;
 151       end if;
 152
 153       --  Set Body_Id. Note that this will be reset to point to the
 154       --  generic copy later on in the generic case.
 155
 156       Body_Id := Defining_Entity (N);
 157
 158       if Present (Corresponding_Spec (N)) then
 159
 160          --  Body is body of package instantiation. Corresponding spec
 161          --  has already been set.
 162
 163          Spec_Id := Corresponding_Spec (N);
 164          Pack_Decl := Unit_Declaration_Node (Spec_Id);
 165
 166       else
 167          Spec_Id := Current_Entity_In_Scope (Defining_Entity (N));
 168
 169          if Present (Spec_Id)
 170            and then Is_Package (Spec_Id)
 171          then
 172             Pack_Decl := Unit_Declaration_Node (Spec_Id);
 173
 174             if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then
 175                Error_Msg_N ("cannot supply body for package renaming", N);
 176                return;
 177
 178             elsif Present (Corresponding_Body (Pack_Decl)) then
 179                Error_Msg_N ("redefinition of package body", N);
 180                return;
 181             end if;
 182
 183          else
 184             Error_Msg_N ("missing specification for package body", N);
 185             return;
 186          end if;
 187
 188          if Is_Package (Spec_Id)
 189            and then
 190              (Scope (Spec_Id) = Standard_Standard
 191                or else Is_Child_Unit (Spec_Id))
 192            and then not Unit_Requires_Body (Spec_Id)
 193          then
 194             if Ada_83 then
 195                Error_Msg_N
 196                  ("optional package body (not allowed in Ada 95)?", N);
 197             else
 198                Error_Msg_N
 199                  ("spec of this package does not allow a body", N);
 200             end if;
 201          end if;
 202       end if;
 203
 204       Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
 205       Style.Check_Identifier (Body_Id, Spec_Id);
 206
 207       if Is_Child_Unit (Spec_Id) then
 208
 209          if Nkind (Parent (N)) /= N_Compilation_Unit then
 210             Error_Msg_NE
 211               ("body of child unit& cannot be an inner package", N, Spec_Id);
 212          end if;
 213
 214          Set_Is_Child_Unit (Body_Id);
 215       end if;
 216
 217       --  Generic package case
 218
 219       if Ekind (Spec_Id) = E_Generic_Package then
 220
 221          --  Disable expansion and perform semantic analysis on copy.
 222          --  The unannotated body will be used in all instantiations.
 223
 224          Body_Id := Defining_Entity (N);
 225          Set_Ekind (Body_Id, E_Package_Body);
 226          Set_Scope (Body_Id, Scope (Spec_Id));
 227          Set_Body_Entity (Spec_Id, Body_Id);
 228          Set_Spec_Entity (Body_Id, Spec_Id);
 229
 230          New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
 231          Rewrite (N, New_N);
 232
 233          --  Update Body_Id to point to the copied node for the remainder
 234          --  of the processing.
 235
 236          Body_Id := Defining_Entity (N);
 237          Start_Generic;
 238       end if;
 239
 240       --  The Body_Id is that of the copied node in the generic case, the
 241       --  current node otherwise. Note that N was rewritten above, so we
 242       --  must be sure to get the latest Body_Id value.
 243
 244       Set_Ekind (Body_Id, E_Package_Body);
 245       Set_Body_Entity (Spec_Id, Body_Id);
 246       Set_Spec_Entity (Body_Id, Spec_Id);
 247
 248       --  Defining name for the package body is not a visible entity: Only
 249       --  the defining name for the declaration is visible.
 250
 251       Set_Etype (Body_Id, Standard_Void_Type);
 252       Set_Scope (Body_Id, Scope (Spec_Id));
 253       Set_Corresponding_Spec (N, Spec_Id);
 254       Set_Corresponding_Body (Pack_Decl, Body_Id);
 255
 256       --  The body entity is not used for semantics or code generation, but
 257       --  it is attached to the entity list of the enclosing scope to simplify
 258       --  the listing of back-annotations for the types it main contain.
 259
 260       if Scope (Spec_Id) /= Standard_Standard then
 261          Append_Entity (Body_Id, Scope (Spec_Id));
 262       end if;
 263
 264       --  Indicate that we are currently compiling the body of the package.
 265
 266       Set_In_Package_Body (Spec_Id);
 267       Set_Has_Completion (Spec_Id);
 268       Last_Spec_Entity := Last_Entity (Spec_Id);
 269
 270       New_Scope (Spec_Id);
 271
 272       Set_Categorization_From_Pragmas (N);
 273
 274       Install_Visible_Declarations (Spec_Id);
 275       Install_Private_Declarations (Spec_Id);
 276       Install_Composite_Operations (Spec_Id);
 277
 278       if Ekind (Spec_Id) = E_Generic_Package then
 279          Set_Use (Generic_Formal_Declarations (Pack_Decl));
 280       end if;
 281
 282       Set_Use (Visible_Declarations (Specification (Pack_Decl)));
 283       Set_Use (Private_Declarations (Specification (Pack_Decl)));
 284
 285       --  This is a nested package, so it may be necessary to declare
 286       --  certain inherited subprograms that are not yet visible because
 287       --  the parent type's subprograms are now visible.
 288
 289       if Ekind (Scope (Spec_Id)) = E_Package
 290         and then Scope (Spec_Id) /= Standard_Standard
 291       then
 292          Declare_Inherited_Private_Subprograms (Spec_Id);
 293       end if;
 294
 295       if Present (Declarations (N)) then
 296          Analyze_Declarations (Declarations (N));
 297       end if;
 298
 299       HSS := Handled_Statement_Sequence (N);
 300
 301       if Present (HSS) then
 302          Process_End_Label (HSS, 't', Spec_Id);
 303          Analyze (HSS);
 304
 305          --  Check that elaboration code in a preelaborable package body is
 306          --  empty other than null statements and labels (RM 10.2.1(6)).
 307
 308          Validate_Null_Statement_Sequence (N);
 309       end if;
 310
 311       Validate_Categorization_Dependency (N, Spec_Id);
 312       Check_Completion (Body_Id);
 313
 314       --  Generate start of body reference. Note that we do this fairly late,
 315       --  because the call will use In_Extended_Main_Source_Unit as a check,
 316       --  and we want to make sure that Corresponding_Stub links are set
 317
 318       Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
 319
 320       --  For a generic package, collect global references and mark
 321       --  them on the original body so that they are not resolved
 322       --  again at the point of instantiation.
 323
 324       if Ekind (Spec_Id) /= E_Package then
 325          Save_Global_References (Original_Node (N));
 326          End_Generic;
 327       end if;
 328
 329       --  The entities of the package body have so far been chained onto
 330       --  the declaration chain for the spec. That's been fine while we
 331       --  were in the body, since we wanted them to be visible, but now
 332       --  that we are leaving the package body, they are no longer visible,
 333       --  so we remove them from the entity chain of the package spec entity,
 334       --  and copy them to the entity chain of the package body entity, where
 335       --  they will never again be visible.
 336
 337       if Present (Last_Spec_Entity) then
 338          Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity));
 339          Set_Next_Entity (Last_Spec_Entity, Empty);
 340          Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
 341          Set_Last_Entity (Spec_Id, Last_Spec_Entity);
 342
 343       else
 344          Set_First_Entity (Body_Id, First_Entity (Spec_Id));
 345          Set_Last_Entity  (Body_Id, Last_Entity  (Spec_Id));
 346          Set_First_Entity (Spec_Id, Empty);
 347          Set_Last_Entity  (Spec_Id, Empty);
 348       end if;
 349
 350       End_Package_Scope (Spec_Id);
 351
 352       --  All entities declared in body are not visible.
 353
 354       declare
 355          E : Entity_Id;
 356
 357       begin
 358          E := First_Entity (Body_Id);
 359
 360          while Present (E) loop
 361             Set_Is_Immediately_Visible (E, False);
 362             Set_Is_Potentially_Use_Visible (E, False);
 363             Set_Is_Hidden (E);
 364
 365             --  Child units may appear on the entity list (for example if
 366             --  they appear in the context of a subunit) but they are not
 367             --  body entities.
 368
 369             if not Is_Child_Unit (E) then
 370                Set_Is_Package_Body_Entity (E);
 371             end if;
 372
 373             Next_Entity (E);
 374          end loop;
 375       end;
 376
 377       Check_References (Body_Id);
 378
 379       --  The processing so far has made all entities of the package body
 380       --  public (i.e. externally visible to the linker). This is in general
 381       --  necessary, since inlined or generic bodies, for which code is
 382       --  generated in other units, may need to see these entities. The
 383       --  following loop runs backwards from the end of the entities of the
 384       --  package body making these entities invisible until we reach a
 385       --  referencer, i.e. a declaration that could reference a previous
 386       --  declaration, a generic body or an inlined body, or a stub (which
 387       --  may contain either of these). This is of course an approximation,
 388       --  but it is conservative and definitely correct.
 389
 390       --  We only do this at the outer (library) level non-generic packages.
 391       --  The reason is simply to cut down on the number of external symbols
 392       --  generated, so this is simply an optimization of the efficiency
 393       --  of the compilation process. It has no other effect.
 394
 395       if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
 396         and then not Is_Generic_Unit (Spec_Id)
 397         and then Present (Declarations (N))
 398       then
 399          Make_Non_Public_Where_Possible : declare
 400             Discard : Boolean;
 401
 402             function Has_Referencer
 403               (L     : List_Id;
 404                Outer : Boolean)
 405                return  Boolean;
 406             --  Traverse the given list of declarations in reverse order.
 407             --  Return True as soon as a referencer is reached. Return
 408             --  False if none is found. The Outer parameter is True for
 409             --  the outer level call, and False for inner level calls for
 410             --  nested packages. If Outer is True, then any entities up
 411             --  to the point of hitting a referencer get their Is_Public
 412             --  flag cleared, so that the entities will be treated as
 413             --  static entities in the C sense, and need not have fully
 414             --  qualified names. For inner levels, we need all names to
 415             --  be fully qualified to deal with the same name appearing
 416             --  in parallel packages (right now this is tied to their
 417             --  being external).
 418
 419             --------------------
 420             -- Has_Referencer --
 421             --------------------
 422
 423             function Has_Referencer
 424               (L     : List_Id;
 425                Outer : Boolean)
 426                return  Boolean
 427             is
 428                D : Node_Id;
 429                E : Entity_Id;
 430                K : Node_Kind;
 431                S : Entity_Id;
 432
 433             begin
 434                if No (L) then
 435                   return False;
 436                end if;
 437
 438                D := Last (L);
 439
 440                while Present (D) loop
 441                   K := Nkind (D);
 442
 443                   if K in N_Body_Stub then
 444                      return True;
 445
 446                   elsif K = N_Subprogram_Body then
 447                      if Acts_As_Spec (D) then
 448                         E := Defining_Entity (D);
 449
 450                         --  An inlined body acts as a referencer. Note also
 451                         --  that we never reset Is_Public for an inlined
 452                         --  subprogram. Gigi requires Is_Public to be set.
 453
 454                         --  Note that we test Has_Pragma_Inline here rather
 455                         --  than Is_Inlined. We are compiling this for a
 456                         --  client, and it is the client who will decide
 457                         --  if actual inlining should occur, so we need to
 458                         --  assume that the procedure could be inlined for
 459                         --  the purpose of accessing global entities.
 460
 461                         if Has_Pragma_Inline (E) then
 462                            return True;
 463                         else
 464                            Set_Is_Public (E, False);
 465                         end if;
 466
 467                      else
 468                         E := Corresponding_Spec (D);
 469
 470                         if Present (E)
 471                           and then (Is_Generic_Unit (E)
 472                                      or else Has_Pragma_Inline (E)
 473                                      or else Is_Inlined (E))
 474                         then
 475                            return True;
 476                         end if;
 477                      end if;
 478
 479                   --  Processing for package bodies
 480
 481                   elsif K = N_Package_Body
 482                     and then Present (Corresponding_Spec (D))
 483                   then
 484                      E := Corresponding_Spec (D);
 485
 486                      --  Generic package body is a referencer. It would
 487                      --  seem that we only have to consider generics that
 488                      --  can be exported, i.e. where the corresponding spec
 489                      --  is the spec of the current package, but because of
 490                      --  nested instantiations, a fully private generic
 491                      --  body may export other private body entities.
 492
 493                      if Is_Generic_Unit (E) then
 494                         return True;
 495
 496                      --  For non-generic package body, recurse into body
 497                      --  unless this is an instance, we ignore instances
 498                      --  since they cannot have references that affect
 499                      --  outer entities.
 500
 501                      elsif not Is_Generic_Instance (E) then
 502                         if Has_Referencer
 503                              (Declarations (D), Outer => False)
 504                         then
 505                            return True;
 506                         end if;
 507                      end if;
 508
 509                   --  Processing for package specs, recurse into declarations.
 510                   --  Again we skip this for the case of generic instances.
 511
 512                   elsif K = N_Package_Declaration then
 513                      S := Specification (D);
 514
 515                      if not Is_Generic_Unit (Defining_Entity (S)) then
 516                         if Has_Referencer
 517                              (Private_Declarations (S), Outer => False)
 518                         then
 519                            return True;
 520                         elsif Has_Referencer
 521                                (Visible_Declarations (S), Outer => False)
 522                         then
 523                            return True;
 524                         end if;
 525                      end if;
 526
 527                   --  Objects and exceptions need not be public if we have
 528                   --  not encountered a referencer so far. We only reset
 529                   --  the flag for outer level entities that are not
 530                   --  imported/exported, and which have no interface name.
 531
 532                   elsif K = N_Object_Declaration
 533                     or else K = N_Exception_Declaration
 534                     or else K = N_Subprogram_Declaration
 535                   then
 536                      E := Defining_Entity (D);
 537
 538                      if Outer
 539                        and then not Is_Imported (E)
 540                        and then not Is_Exported (E)
 541                        and then No (Interface_Name (E))
 542                      then
 543                         Set_Is_Public (E, False);
 544                      end if;
 545                   end if;
 546
 547                   Prev (D);
 548                end loop;
 549
 550                return False;
 551             end Has_Referencer;
 552
 553          --  Start of processing for Make_Non_Public_Where_Possible
 554
 555          begin
 556             Discard := Has_Referencer (Declarations (N), Outer => True);
 557          end Make_Non_Public_Where_Possible;
 558       end if;
 559
 560       --  If expander is not active, then here is where we turn off the
 561       --  In_Package_Body flag, otherwise it is turned off at the end of
 562       --  the corresponding expansion routine. If this is an instance body,
 563       --  we need to qualify names of local entities, because the body may
 564       --  have been compiled as a preliminary to another instantiation.
 565
 566       if not Expander_Active then
 567          Set_In_Package_Body (Spec_Id, False);
 568
 569          if Is_Generic_Instance (Spec_Id)
 570            and then Operating_Mode = Generate_Code
 571          then
 572             Qualify_Entity_Names (N);
 573          end if;
 574       end if;
 575    end Analyze_Package_Body;
 576
 577    ---------------------------------
 578    -- Analyze_Package_Declaration --
 579    ---------------------------------
 580
 581    procedure Analyze_Package_Declaration (N : Node_Id) is
 582       Id : constant Node_Id := Defining_Entity (N);
 583       PF : Boolean;
 584
 585    begin
 586       Generate_Definition (Id);
 587       Enter_Name (Id);
 588       Set_Ekind (Id, E_Package);
 589       Set_Etype (Id, Standard_Void_Type);
 590       New_Scope (Id);
 591
 592       PF := Is_Pure (Enclosing_Lib_Unit_Entity);
 593       Set_Is_Pure (Id, PF);
 594
 595       Set_Categorization_From_Pragmas (N);
 596
 597       if Debug_Flag_C then
 598          Write_Str ("====  Compiling package spec ");
 599          Write_Name (Chars (Id));
 600          Write_Str (" from ");
 601          Write_Location (Sloc (N));
 602          Write_Eol;
 603       end if;
 604
 605       Analyze (Specification (N));
 606       Validate_Categorization_Dependency (N, Id);
 607       End_Package_Scope (Id);
 608
 609       --  For a compilation unit, indicate whether it needs a body, and
 610       --  whether elaboration warnings may be meaningful on it.
 611
 612       if Nkind (Parent (N)) = N_Compilation_Unit then
 613          Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
 614
 615          if not Body_Required (Parent (N)) then
 616             Set_Suppress_Elaboration_Warnings (Id);
 617          end if;
 618
 619          Validate_RT_RAT_Component (N);
 620       end if;
 621
 622       --  Clear Not_Source_Assigned on all variables in the package spec,
 623       --  because at this stage some client, or the body, or a child package,
 624       --  may modify variables in the declaration. Note that we wait till now
 625       --  to reset these flags, because during analysis of the declaration,
 626       --  the flags correctly indicated the status up to that point. We
 627       --  similarly clear any Is_True_Constant indications.
 628
 629       declare
 630          E : Entity_Id;
 631
 632       begin
 633          E := First_Entity (Id);
 634          while Present (E) loop
 635             if Ekind (E) = E_Variable then
 636                Set_Not_Source_Assigned (E, False);
 637                Set_Is_True_Constant    (E, False);
 638             end if;
 639
 640             Next_Entity (E);
 641          end loop;
 642       end;
 643    end Analyze_Package_Declaration;
 644
 645    -----------------------------------
 646    -- Analyze_Package_Specification --
 647    -----------------------------------
 648
 649    procedure Analyze_Package_Specification (N : Node_Id) is
 650       Id           : constant Entity_Id  := Defining_Entity (N);
 651       Orig_Decl    : constant Node_Id    := Original_Node (Parent (N));
 652       Vis_Decls    : constant List_Id    := Visible_Declarations (N);
 653       Priv_Decls   : constant List_Id    := Private_Declarations (N);
 654       E            : Entity_Id;
 655       L            : Entity_Id;
 656       Public_Child : Boolean             := False;
 657
 658       function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
 659       --  Child and Unit are entities of compilation units. True if Child
 660       --  is a public child of Parent as defined in 10.1.1
 661
 662       function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is
 663       begin
 664          if not Is_Private_Descendant (Child) then
 665             return True;
 666          else
 667             if Child = Unit then
 668                return not Private_Present (
 669                  Parent (Unit_Declaration_Node (Child)));
 670             else
 671                return Is_Public_Child (Scope (Child), Unit);
 672             end if;
 673          end if;
 674       end Is_Public_Child;
 675
 676    --  Start of processing for Analyze_Package_Specification
 677
 678    begin
 679       if Present (Vis_Decls) then
 680          Analyze_Declarations (Vis_Decls);
 681       end if;
 682
 683       --  Verify that incomplete types have received full declarations.
 684
 685       E := First_Entity (Id);
 686
 687       while Present (E) loop
 688          if Ekind (E) = E_Incomplete_Type
 689            and then No (Full_View (E))
 690          then
 691             Error_Msg_N ("no declaration in visible part for incomplete}", E);
 692          end if;
 693
 694          Next_Entity (E);
 695       end loop;
 696
 697       if Is_Remote_Call_Interface (Id)
 698          and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
 699       then
 700          Validate_RCI_Declarations (Id);
 701       end if;
 702
 703       --  Save global references in the visible declarations, before
 704       --  installing private declarations of parent unit if there is one,
 705       --  because the privacy status of types defined in the parent will
 706       --  change. This is only relevant for generic child units, but is
 707       --  done in all cases for uniformity.
 708
 709       if Ekind (Id) = E_Generic_Package
 710         and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
 711       then
 712          declare
 713             Orig_Spec : constant Node_Id    := Specification (Orig_Decl);
 714             Save_Priv : constant List_Id := Private_Declarations (Orig_Spec);
 715
 716          begin
 717             Set_Private_Declarations (Orig_Spec, Empty_List);
 718             Save_Global_References   (Orig_Decl);
 719             Set_Private_Declarations (Orig_Spec, Save_Priv);
 720          end;
 721       end if;
 722
 723       --  If package is a public child unit, then make the private
 724       --  declarations of the parent visible.
 725
 726       if Present (Parent_Spec (Parent (N))) then
 727          declare
 728             Par       : Entity_Id := Id;
 729             Pack_Decl : Node_Id;
 730
 731          begin
 732             while Scope (Par) /= Standard_Standard
 733               and then Is_Public_Child (Id, Par)
 734             loop
 735                Public_Child := True;
 736                Par := Scope (Par);
 737                Install_Private_Declarations (Par);
 738                Pack_Decl := Unit_Declaration_Node (Par);
 739                Set_Use (Private_Declarations (Specification (Pack_Decl)));
 740             end loop;
 741          end;
 742       end if;
 743
 744       --  Analyze private part if present. The flag In_Private_Part is
 745       --  reset in End_Package_Scope.
 746
 747       L := Last_Entity (Id);
 748
 749       if Present (Priv_Decls) then
 750          L := Last_Entity (Id);
 751          Set_In_Private_Part (Id);
 752
 753          --  Upon entering a public child's private part, it may be
 754          --  necessary to declare subprograms that were derived in
 755          --  the package visible part but not yet made visible.
 756
 757          if Public_Child then
 758             Declare_Inherited_Private_Subprograms (Id);
 759          end if;
 760
 761          Analyze_Declarations (Priv_Decls);
 762
 763          --  The first private entity is the immediate follower of the last
 764          --  visible entity, if there was one.
 765
 766          if Present (L) then
 767             Set_First_Private_Entity (Id, Next_Entity (L));
 768          else
 769             Set_First_Private_Entity (Id, First_Entity (Id));
 770          end if;
 771
 772       --  There may be inherited private subprograms that need to be
 773       --  declared, even in the absence of an explicit private part.
 774       --  If there are any public declarations in the package and
 775       --  the package is a public child unit, then an implicit private
 776       --  part is assumed.
 777
 778       elsif Present (L) and then Public_Child then
 779          Set_In_Private_Part (Id);
 780          Declare_Inherited_Private_Subprograms (Id);
 781          Set_First_Private_Entity (Id, Next_Entity (L));
 782       end if;
 783
 784       --  Check rule of 3.6(11), which in general requires
 785       --  waiting till all full types have been seen.
 786
 787       E := First_Entity (Id);
 788       while Present (E) loop
 789          if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then
 790             Check_Aliased_Component_Types (E);
 791          end if;
 792
 793          Next_Entity (E);
 794       end loop;
 795
 796       if Ekind (Id) = E_Generic_Package
 797         and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
 798         and then Present (Priv_Decls)
 799       then
 800          --  Save global references in private declarations, ignoring the
 801          --  visible declarations that were processed earlier.
 802
 803          declare
 804             Orig_Spec : constant Node_Id := Specification (Orig_Decl);
 805             Save_Vis  : constant List_Id := Visible_Declarations (Orig_Spec);
 806             Save_Form : constant List_Id :=
 807                           Generic_Formal_Declarations (Orig_Decl);
 808
 809          begin
 810             Set_Visible_Declarations        (Orig_Spec, Empty_List);
 811             Set_Generic_Formal_Declarations (Orig_Decl, Empty_List);
 812             Save_Global_References          (Orig_Decl);
 813             Set_Generic_Formal_Declarations (Orig_Decl, Save_Form);
 814             Set_Visible_Declarations        (Orig_Spec, Save_Vis);
 815          end;
 816       end if;
 817
 818       Process_End_Label (N, 'e', Id);
 819    end Analyze_Package_Specification;
 820
 821    --------------------------------------
 822    -- Analyze_Private_Type_Declaration --
 823    --------------------------------------
 824
 825    procedure Analyze_Private_Type_Declaration (N : Node_Id) is
 826       PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity);
 827       Id : Entity_Id := Defining_Identifier (N);
 828
 829    begin
 830       Generate_Definition (Id);
 831       Set_Is_Pure         (Id, PF);
 832       Init_Size_Align     (Id);
 833
 834       if (Ekind (Current_Scope) /= E_Package
 835           and then Ekind (Current_Scope) /= E_Generic_Package)
 836         or else In_Private_Part (Current_Scope)
 837       then
 838          Error_Msg_N ("invalid context for private declaration", N);
 839       end if;
 840
 841       New_Private_Type (N, Id, N);
 842       Set_Depends_On_Private (Id);
 843       Set_Has_Delayed_Freeze (Id);
 844
 845    end Analyze_Private_Type_Declaration;
 846
 847    -------------------------------------------
 848    -- Declare_Inherited_Private_Subprograms --
 849    -------------------------------------------
 850
 851    procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
 852       E : Entity_Id;
 853       Op_List        : Elist_Id;
 854       Op_Elmt        : Elmt_Id;
 855       Op_Elmt_2      : Elmt_Id;
 856       Prim_Op        : Entity_Id;
 857       New_Op         : Entity_Id;
 858       Parent_Subp    : Entity_Id;
 859       Found_Explicit : Boolean;
 860       Decl_Privates  : Boolean;
 861
 862       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
 863       --  Check whether an inherited subprogram is an operation of an
 864       --  untagged derived type.
 865
 866       ---------------------
 867       -- Is_Primitive_Of --
 868       ---------------------
 869
 870       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is
 871          Formal : Entity_Id;
 872
 873       begin
 874          if Etype (S) = T then
 875             return True;
 876
 877          else
 878             Formal := First_Formal (S);
 879
 880             while Present (Formal) loop
 881                if Etype (Formal) = T then
 882                   return True;
 883                end if;
 884
 885                Next_Formal (Formal);
 886             end loop;
 887
 888             return False;
 889          end if;
 890       end Is_Primitive_Of;
 891
 892    --  Start of processing for Declare_Inherited_Private_Subprograms
 893
 894    begin
 895       E := First_Entity (Id);
 896
 897       while Present (E) loop
 898
 899          --  If the entity is a nonprivate type extension whose parent
 900          --  type is declared in an open scope, then the type may have
 901          --  inherited operations that now need to be made visible.
 902          --  Ditto if the entity is a formal derived type in a child unit.
 903
 904          if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
 905                or else
 906              (Nkind (Parent (E)) = N_Private_Extension_Declaration
 907                and then Is_Generic_Type (E)))
 908            and then In_Open_Scopes (Scope (Etype (E)))
 909            and then E = Base_Type (E)
 910          then
 911             if Is_Tagged_Type (E) then
 912                Op_List       := Primitive_Operations (E);
 913                Op_Elmt       := First_Elmt (Op_List);
 914                New_Op        := Empty;
 915                Decl_Privates := False;
 916
 917                while Present (Op_Elmt) loop
 918                   Prim_Op := Node (Op_Elmt);
 919
 920                   --  If the primitive operation is an implicit operation
 921                   --  with an internal name whose parent operation has
 922                   --  a normal name, then we now need to either declare the
 923                   --  operation (i.e., make it visible), or replace it
 924                   --  by an overriding operation if one exists.
 925
 926                   if Present (Alias (Prim_Op))
 927                     and then not Comes_From_Source (Prim_Op)
 928                     and then Is_Internal_Name (Chars (Prim_Op))
 929                     and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
 930                   then
 931                      Parent_Subp := Alias (Prim_Op);
 932
 933                      Found_Explicit := False;
 934                      Op_Elmt_2 := Next_Elmt (Op_Elmt);
 935                      while Present (Op_Elmt_2) loop
 936                         if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
 937                           and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
 938                         then
 939                            --  The private inherited operation has been
 940                            --  overridden by an explicit subprogram, so
 941                            --  change the private op's list element to
 942                            --  designate the explicit so the explicit
 943                            --  one will get the right dispatching slot.
 944
 945                            New_Op := Node (Op_Elmt_2);
 946                            Replace_Elmt (Op_Elmt, New_Op);
 947                            Remove_Elmt (Op_List, Op_Elmt_2);
 948                            Found_Explicit := True;
 949                            Decl_Privates  := True;
 950                            exit;
 951                         end if;
 952
 953                         Next_Elmt (Op_Elmt_2);
 954                      end loop;
 955
 956                      if not Found_Explicit then
 957                         Derive_Subprogram
 958                           (New_Op, Alias (Prim_Op), E, Etype (E));
 959
 960                         pragma Assert
 961                           (Is_Dispatching_Operation (New_Op)
 962                             and then Node (Last_Elmt (Op_List)) = New_Op);
 963
 964                         --  Substitute the new operation for the old one
 965                         --  in the type's primitive operations list. Since
 966                         --  the new operation was also just added to the end
 967                         --  of list, the last element must be removed.
 968
 969                         --  (Question: is there a simpler way of declaring
 970                         --  the operation, say by just replacing the name
 971                         --  of the earlier operation, reentering it in the
 972                         --  in the symbol table (how?), and marking it as
 973                         --  private???)
 974
 975                         Replace_Elmt (Op_Elmt, New_Op);
 976                         Remove_Last_Elmt (Op_List);
 977                         Decl_Privates := True;
 978                      end if;
 979                   end if;
 980
 981                   Next_Elmt (Op_Elmt);
 982                end loop;
 983
 984                --  The type's DT attributes need to be recalculated
 985                --  in the case where private dispatching operations
 986                --  have been added or overridden. Normally this action
 987                --  occurs during type freezing, but we force it here
 988                --  since the type may already have been frozen (e.g.,
 989                --  if the type's package has an empty private part).
 990                --  This can only be done if expansion is active, otherwise
 991                --  Tag may not be present.
 992
 993                if Decl_Privates
 994                  and then Expander_Active
 995                then
 996                   Set_All_DT_Position (E);
 997                end if;
 998
 999             else
1000                --   Non-tagged type, scan forward to locate
1001                --   inherited hidden operations.
1002
1003                Prim_Op := Next_Entity (E);
1004
1005                while Present (Prim_Op) loop
1006                   if Is_Subprogram (Prim_Op)
1007                     and then Present (Alias (Prim_Op))
1008                     and then not Comes_From_Source (Prim_Op)
1009                     and then Is_Internal_Name (Chars (Prim_Op))
1010                     and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
1011                     and then Is_Primitive_Of (E, Prim_Op)
1012                   then
1013                      Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
1014                   end if;
1015
1016                   Next_Entity (Prim_Op);
1017                end loop;
1018             end if;
1019          end if;
1020
1021          Next_Entity (E);
1022       end loop;
1023    end Declare_Inherited_Private_Subprograms;
1024
1025    -----------------------
1026    -- End_Package_Scope --
1027    -----------------------
1028
1029    procedure End_Package_Scope (P : Entity_Id) is
1030    begin
1031       Uninstall_Declarations (P);
1032       Pop_Scope;
1033    end End_Package_Scope;
1034
1035    ---------------------------
1036    -- Exchange_Declarations --
1037    ---------------------------
1038
1039    procedure Exchange_Declarations (Id : Entity_Id) is
1040       Full_Id : constant Entity_Id := Full_View (Id);
1041       H1      : constant Entity_Id := Homonym (Id);
1042       Next1   : constant Entity_Id := Next_Entity (Id);
1043       H2      : Entity_Id;
1044       Next2   : Entity_Id;
1045
1046    begin
1047       --  If missing full declaration for type, nothing to exchange
1048
1049       if No (Full_Id) then
1050          return;
1051       end if;
1052
1053       --  Otherwise complete the exchange, and preserve semantic links
1054
1055       Next2 := Next_Entity (Full_Id);
1056       H2    := Homonym (Full_Id);
1057
1058       --  Reset full declaration pointer to reflect the switched entities
1059       --  and readjust the next entity chains.
1060
1061       Exchange_Entities (Id, Full_Id);
1062
1063       Set_Next_Entity (Id, Next1);
1064       Set_Homonym     (Id, H1);
1065
1066       Set_Full_View   (Full_Id, Id);
1067       Set_Next_Entity (Full_Id, Next2);
1068       Set_Homonym     (Full_Id, H2);
1069    end Exchange_Declarations;
1070
1071    ----------------------------------
1072    -- Install_Composite_Operations --
1073    ----------------------------------
1074
1075    procedure Install_Composite_Operations (P : Entity_Id) is
1076       Id : Entity_Id;
1077
1078    begin
1079       Id := First_Entity (P);
1080
1081       while Present (Id) loop
1082
1083          if Is_Type (Id)
1084            and then (Is_Limited_Composite (Id)
1085                       or else Is_Private_Composite (Id))
1086            and then No (Private_Component (Id))
1087          then
1088             Set_Is_Limited_Composite (Id, False);
1089             Set_Is_Private_Composite (Id, False);
1090          end if;
1091
1092          Next_Entity (Id);
1093       end loop;
1094    end Install_Composite_Operations;
1095
1096    ----------------------------
1097    -- Install_Package_Entity --
1098    ----------------------------
1099
1100    procedure Install_Package_Entity (Id : Entity_Id) is
1101    begin
1102       if not Is_Internal (Id) then
1103          if Debug_Flag_E then
1104             Write_Str ("Install: ");
1105             Write_Name (Chars (Id));
1106             Write_Eol;
1107          end if;
1108
1109          if not Is_Child_Unit (Id) then
1110             Set_Is_Immediately_Visible (Id);
1111          end if;
1112
1113       end if;
1114    end Install_Package_Entity;
1115
1116    ----------------------------------
1117    -- Install_Private_Declarations --
1118    ----------------------------------
1119
1120    procedure Install_Private_Declarations (P : Entity_Id) is
1121       Id        : Entity_Id;
1122       Priv_Elmt : Elmt_Id;
1123       Priv      : Entity_Id;
1124       Full      : Entity_Id;
1125
1126    begin
1127       --  First exchange declarations for private types, so that the
1128       --  full declaration is visible. For each private type, we check
1129       --  its Private_Dependents list and also exchange any subtypes of
1130       --  or derived types from it. Finally, if this is a Taft amendment
1131       --  type, the incomplete declaration is irrelevant, and we want to
1132       --  link the eventual full declaration with the original private
1133       --  one so we also skip the exchange.
1134
1135       Id := First_Entity (P);
1136
1137       while Present (Id) and then Id /= First_Private_Entity (P) loop
1138
1139          if Is_Private_Base_Type (Id)
1140            and then Comes_From_Source (Full_View (Id))
1141            and then Present (Full_View (Id))
1142            and then Scope (Full_View (Id)) = Scope (Id)
1143            and then Ekind (Full_View (Id)) /= E_Incomplete_Type
1144          then
1145             Priv_Elmt := First_Elmt (Private_Dependents (Id));
1146
1147             --  If there is a use-type clause on the private type, set the
1148             --  full view accordingly.
1149
1150             Set_In_Use (Full_View (Id), In_Use (Id));
1151             Full := Full_View (Id);
1152
1153             if Is_Private_Base_Type (Full)
1154               and then Has_Private_Declaration (Full)
1155               and then Nkind (Parent (Full)) = N_Full_Type_Declaration
1156               and then In_Open_Scopes (Scope (Etype (Full)))
1157               and then In_Package_Body (Current_Scope)
1158               and then not Is_Private_Type (Etype (Full))
1159             then
1160                --  This is the completion of a private type by a derivation
1161                --  from another private type which is not private anymore. This
1162                --  can only happen in a package nested within a child package,
1163                --  when the parent type is defined in the parent unit. At this
1164                --  point the current type is not private either, and we have to
1165                --  install the underlying full view, which is now visible.
1166
1167                if No (Full_View (Full))
1168                  and then Present (Underlying_Full_View (Full))
1169                then
1170                   Set_Full_View (Id, Underlying_Full_View (Full));
1171                   Set_Underlying_Full_View (Full, Empty);
1172                   Set_Is_Frozen (Full_View (Id));
1173                end if;
1174             end if;
1175
1176             Exchange_Declarations (Id);
1177             Set_Is_Immediately_Visible (Id);
1178
1179             while Present (Priv_Elmt) loop
1180                Priv := Node (Priv_Elmt);
1181
1182                --  Before the exchange, verify that the presence of the
1183                --  Full_View field. It will be empty if the entity
1184                --  has already been installed due to a previous call.
1185
1186                if Present (Full_View (Priv))
1187                  and then Is_Visible_Dependent (Priv)
1188                then
1189
1190                   --  For each subtype that is swapped, we also swap the
1191                   --  reference to it in Private_Dependents, to allow access
1192                   --  to it when we swap them out in End_Package_Scope.
1193
1194                   Replace_Elmt (Priv_Elmt, Full_View (Priv));
1195                   Exchange_Declarations (Priv);
1196                   Set_Is_Immediately_Visible
1197                     (Priv, In_Open_Scopes (Scope (Priv)));
1198                   Set_Is_Potentially_Use_Visible
1199                     (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
1200                end if;
1201
1202                Next_Elmt (Priv_Elmt);
1203             end loop;
1204
1205             null;
1206          end if;
1207
1208          Next_Entity (Id);
1209       end loop;
1210
1211       --  Next make other declarations in the private part visible as well.
1212
1213       Id := First_Private_Entity (P);
1214
1215       while Present (Id) loop
1216          Install_Package_Entity (Id);
1217          Next_Entity (Id);
1218       end loop;
1219
1220       --  Indicate that the private part is currently visible, so it can be
1221       --  properly reset on exit.
1222
1223       Set_In_Private_Part (P);
1224    end Install_Private_Declarations;
1225
1226    ----------------------------------
1227    -- Install_Visible_Declarations --
1228    ----------------------------------
1229
1230    procedure Install_Visible_Declarations (P : Entity_Id) is
1231       Id : Entity_Id;
1232
1233    begin
1234       Id := First_Entity (P);
1235
1236       while Present (Id) and then Id /= First_Private_Entity (P) loop
1237          Install_Package_Entity (Id);
1238          Next_Entity (Id);
1239       end loop;
1240    end Install_Visible_Declarations;
1241
1242    ----------------------
1243    -- Is_Fully_Visible --
1244    ----------------------
1245
1246    --  The full declaration of a private type is visible in the private
1247    --  part of the package declaration, and in the package body, at which
1248    --  point the full declaration must have been given.
1249
1250    function Is_Fully_Visible (Type_Id : Entity_Id) return Boolean is
1251       S : constant Entity_Id := Scope (Type_Id);
1252
1253    begin
1254       if Is_Generic_Type (Type_Id) then
1255          return False;
1256
1257       elsif In_Private_Part (S) then
1258          return Present (Full_View (Type_Id));
1259
1260       else
1261          return In_Package_Body (S);
1262       end if;
1263    end Is_Fully_Visible;
1264
1265    --------------------------
1266    -- Is_Private_Base_Type --
1267    --------------------------
1268
1269    function Is_Private_Base_Type (E : Entity_Id) return Boolean is
1270    begin
1271       return Ekind (E) = E_Private_Type
1272         or else Ekind (E) = E_Limited_Private_Type
1273         or else Ekind (E) = E_Record_Type_With_Private;
1274    end Is_Private_Base_Type;
1275
1276    --------------------------
1277    -- Is_Visible_Dependent --
1278    --------------------------
1279
1280    function Is_Visible_Dependent (Dep : Entity_Id) return Boolean
1281    is
1282       S : constant Entity_Id := Scope (Dep);
1283
1284    begin
1285       --  Renamings created for actual types have the visibility of the
1286       --  actual.
1287
1288       if Ekind (S) = E_Package
1289         and then Is_Generic_Instance (S)
1290         and then (Is_Generic_Actual_Type (Dep)
1291                    or else Is_Generic_Actual_Type (Full_View (Dep)))
1292       then
1293          return True;
1294
1295       elsif not (Is_Derived_Type (Dep))
1296         and then Is_Derived_Type (Full_View (Dep))
1297       then
1298          return In_Open_Scopes (S);
1299       else
1300          return True;
1301       end if;
1302    end Is_Visible_Dependent;
1303
1304    ----------------------------
1305    -- May_Need_Implicit_Body --
1306    ----------------------------
1307
1308    procedure May_Need_Implicit_Body (E : Entity_Id) is
1309       P     : constant Node_Id := Unit_Declaration_Node (E);
1310       S     : constant Node_Id := Parent (P);
1311       B     : Node_Id;
1312       Decls : List_Id;
1313
1314    begin
1315       if not Has_Completion (E)
1316         and then Nkind (P) = N_Package_Declaration
1317         and then Present (Activation_Chain_Entity (P))
1318       then
1319          B :=
1320            Make_Package_Body (Sloc (E),
1321              Defining_Unit_Name => Make_Defining_Identifier (Sloc (E),
1322                Chars => Chars (E)),
1323              Declarations  => New_List);
1324
1325          if Nkind (S) = N_Package_Specification then
1326             if Present (Private_Declarations (S)) then
1327                Decls := Private_Declarations (S);
1328             else
1329                Decls := Visible_Declarations (S);
1330             end if;
1331          else
1332             Decls := Declarations (S);
1333          end if;
1334
1335          Append (B, Decls);
1336          Analyze (B);
1337       end if;
1338    end May_Need_Implicit_Body;
1339
1340    ----------------------
1341    -- New_Private_Type --
1342    ----------------------
1343
1344    procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is
1345    begin
1346       Enter_Name (Id);
1347
1348       if Limited_Present (Def) then
1349          Set_Ekind (Id, E_Limited_Private_Type);
1350       else
1351          Set_Ekind (Id, E_Private_Type);
1352       end if;
1353
1354       Set_Etype              (Id, Id);
1355       Set_Has_Delayed_Freeze (Id);
1356       Set_Is_First_Subtype   (Id);
1357       Init_Size_Align        (Id);
1358
1359       Set_Is_Constrained (Id,
1360         No (Discriminant_Specifications (N))
1361           and then not Unknown_Discriminants_Present (N));
1362
1363       --  Set tagged flag before processing discriminants, to catch
1364       --  illegal usage.
1365
1366       Set_Is_Tagged_Type (Id, Tagged_Present (Def));
1367
1368       Set_Discriminant_Constraint (Id, No_Elist);
1369       Set_Girder_Constraint (Id, No_Elist);
1370
1371       if Present (Discriminant_Specifications (N)) then
1372          New_Scope (Id);
1373          Process_Discriminants (N);
1374          End_Scope;
1375
1376       elsif Unknown_Discriminants_Present (N) then
1377          Set_Has_Unknown_Discriminants (Id);
1378       end if;
1379
1380       Set_Private_Dependents (Id, New_Elmt_List);
1381
1382       if Tagged_Present (Def) then
1383          Set_Ekind                (Id, E_Record_Type_With_Private);
1384          Make_Class_Wide_Type     (Id);
1385          Set_Primitive_Operations (Id, New_Elmt_List);
1386          Set_Is_Abstract          (Id, Abstract_Present (Def));
1387          Set_Is_Limited_Record    (Id, Limited_Present (Def));
1388          Set_Has_Delayed_Freeze   (Id, True);
1389
1390       elsif Abstract_Present (Def) then
1391          Error_Msg_N ("only a tagged type can be abstract", N);
1392       end if;
1393    end New_Private_Type;
1394
1395    ------------------------------
1396    -- Preserve_Full_Attributes --
1397    ------------------------------
1398
1399    procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
1400       Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
1401
1402    begin
1403       Set_Size_Info                   (Priv,                          (Full));
1404       Set_RM_Size                     (Priv, RM_Size                  (Full));
1405       Set_Size_Known_At_Compile_Time  (Priv, Size_Known_At_Compile_Time
1406                                                                       (Full));
1407
1408       if Priv_Is_Base_Type then
1409          Set_Is_Controlled            (Priv, Is_Controlled (Base_Type (Full)));
1410          Set_Finalize_Storage_Only    (Priv, Finalize_Storage_Only
1411                                                            (Base_Type (Full)));
1412          Set_Has_Task                 (Priv, Has_Task      (Base_Type (Full)));
1413          Set_Has_Controlled_Component (Priv, Has_Controlled_Component
1414                                                            (Base_Type (Full)));
1415       end if;
1416
1417       Set_Freeze_Node                 (Priv, Freeze_Node              (Full));
1418
1419       if Is_Tagged_Type (Priv)
1420         and then Is_Tagged_Type (Full)
1421         and then not Error_Posted (Full)
1422       then
1423          if Priv_Is_Base_Type then
1424             Set_Access_Disp_Table     (Priv, Access_Disp_Table
1425                                                            (Base_Type (Full)));
1426          end if;
1427
1428          Set_First_Entity             (Priv, First_Entity             (Full));
1429          Set_Last_Entity              (Priv, Last_Entity              (Full));
1430       end if;
1431    end Preserve_Full_Attributes;
1432
1433    ----------------------------
1434    -- Uninstall_Declarations --
1435    ----------------------------
1436
1437    procedure Uninstall_Declarations (P : Entity_Id) is
1438       Id   : Entity_Id;
1439       Decl : Node_Id := Unit_Declaration_Node (P);
1440       Full : Entity_Id;
1441       Priv_Elmt : Elmt_Id;
1442       Priv_Sub  : Entity_Id;
1443
1444       function Type_In_Use (T : Entity_Id) return Boolean;
1445       --  Check whether type or base type appear in an active use_type clause.
1446
1447       function Type_In_Use (T : Entity_Id) return Boolean is
1448       begin
1449          return Scope (Base_Type (T)) = P
1450            and then  (In_Use (T) or else In_Use (Base_Type (T)));
1451       end Type_In_Use;
1452
1453    --  Start of processing for Uninstall_Declarations
1454
1455    begin
1456       Id := First_Entity (P);
1457
1458       while Present (Id) and then Id /= First_Private_Entity (P) loop
1459          if Debug_Flag_E then
1460             Write_Str ("unlinking visible entity ");
1461             Write_Int (Int (Id));
1462             Write_Eol;
1463          end if;
1464
1465          --  On  exit from the package scope, we must preserve the visibility
1466          --  established by use clauses in the current scope. Two cases:
1467
1468          --  a) If the entity is an operator, it may be a primitive operator of
1469          --  a type for which there is a visible use-type clause.
1470
1471          --  b) for other entities, their use-visibility is determined by a
1472          --  visible use clause for the package itself. For a generic instance,
1473          --  the instantiation of the formals appears in the visible part,
1474          --  but the formals are private and remain so.
1475
1476          if Ekind (Id) = E_Function
1477            and then  Is_Operator_Symbol_Name (Chars (Id))
1478            and then not Is_Hidden (Id)
1479          then
1480             Set_Is_Potentially_Use_Visible (Id,
1481               In_Use (P)
1482               or else Type_In_Use (Etype (Id))
1483               or else Type_In_Use (Etype (First_Formal (Id)))
1484               or else (Present (Next_Formal (First_Formal (Id)))
1485                          and then
1486                            Type_In_Use
1487                              (Etype (Next_Formal (First_Formal (Id))))));
1488          else
1489             Set_Is_Potentially_Use_Visible (Id,
1490               In_Use (P) and not Is_Hidden (Id));
1491          end if;
1492
1493          --  Local entities are not immediately visible outside of the package.
1494
1495          Set_Is_Immediately_Visible (Id, False);
1496
1497          if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
1498             Check_Abstract_Overriding (Id);
1499          end if;
1500
1501          if (Ekind (Id) = E_Private_Type
1502                or else Ekind (Id) = E_Limited_Private_Type)
1503            and then No (Full_View (Id))
1504            and then not Is_Generic_Type (Id)
1505            and then not Is_Derived_Type (Id)
1506          then
1507             Error_Msg_N ("missing full declaration for private type&", Id);
1508
1509          elsif Ekind (Id) = E_Record_Type_With_Private
1510            and then not Is_Generic_Type (Id)
1511            and then No (Full_View (Id))
1512          then
1513             if Nkind (Parent (Id)) = N_Private_Type_Declaration then
1514                Error_Msg_N ("missing full declaration for private type&", Id);
1515             else
1516                Error_Msg_N
1517                  ("missing full declaration for private extension", Id);
1518             end if;
1519
1520          elsif Ekind (Id) = E_Constant
1521            and then No (Constant_Value (Id))
1522            and then No (Full_View (Id))
1523            and then not Is_Imported (Id)
1524            and then (Nkind (Parent (Id)) /= N_Object_Declaration
1525                       or else not No_Initialization (Parent (Id)))
1526          then
1527             Error_Msg_N ("missing full declaration for deferred constant", Id);
1528          end if;
1529
1530          Next_Entity (Id);
1531       end loop;
1532
1533       --  If the specification was installed as the parent of a public child
1534       --  unit, the private declarations were not installed, and there is
1535       --  nothing to do.
1536
1537       if not In_Private_Part (P) then
1538          return;
1539       else
1540          Set_In_Private_Part (P, False);
1541       end if;
1542
1543       --  Make private entities invisible and exchange full and private
1544       --  declarations for private types.
1545
1546       while Present (Id) loop
1547          if Debug_Flag_E then
1548             Write_Str ("unlinking private entity ");
1549             Write_Int (Int (Id));
1550             Write_Eol;
1551          end if;
1552
1553          if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
1554             Check_Abstract_Overriding (Id);
1555          end if;
1556
1557          Set_Is_Immediately_Visible (Id, False);
1558
1559          if Is_Private_Base_Type (Id)
1560            and then Present (Full_View (Id))
1561          then
1562             Full := Full_View (Id);
1563
1564             --  If the partial view is not declared in the visible part
1565             --  of the package (as is the case when it is a type derived
1566             --  from some other private type in the private part if the
1567             --  current package), no exchange takes place.
1568
1569             if No (Parent (Id))
1570               or else List_Containing (Parent (Id))
1571                 /= Visible_Declarations (Specification (Decl))
1572             then
1573                goto Next_Id;
1574             end if;
1575
1576             --  The entry in the private part points to the full declaration,
1577             --  which is currently visible. Exchange them so only the private
1578             --  type declaration remains accessible, and link private and
1579             --  full declaration in the opposite direction. Before the actual
1580             --  exchange, we copy back attributes of the full view that
1581             --  must be available to the partial view too.
1582
1583             Preserve_Full_Attributes (Id, Full);
1584
1585             Set_Is_Potentially_Use_Visible (Id, In_Use (P));
1586
1587             if  Is_Indefinite_Subtype (Full)
1588               and then not Is_Indefinite_Subtype (Id)
1589             then
1590                Error_Msg_N
1591                  ("full view of type must be definite subtype", Full);
1592             end if;
1593
1594             Priv_Elmt := First_Elmt (Private_Dependents (Id));
1595             Exchange_Declarations (Id);
1596
1597             --  Swap out the subtypes and derived types of Id that were
1598             --  compiled in this scope, or installed previously by
1599             --  Install_Private_Declarations.
1600             --  Before we do the swap, we verify the presence of the
1601             --  Full_View field which may be empty due to a swap by
1602             --  a previous call to End_Package_Scope (e.g. from the
1603             --  freezing mechanism).
1604
1605             while Present (Priv_Elmt) loop
1606                Priv_Sub := Node (Priv_Elmt);
1607
1608                if Present (Full_View (Priv_Sub)) then
1609
1610                   if Scope (Priv_Sub) = P
1611                      or else not In_Open_Scopes (Scope (Priv_Sub))
1612                   then
1613                      Set_Is_Immediately_Visible (Priv_Sub, False);
1614                   end if;
1615
1616                   if Is_Visible_Dependent (Priv_Sub) then
1617                      Preserve_Full_Attributes
1618                        (Priv_Sub, Full_View (Priv_Sub));
1619                      Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub));
1620                      Exchange_Declarations (Priv_Sub);
1621                   end if;
1622                end if;
1623
1624                Next_Elmt (Priv_Elmt);
1625             end loop;
1626
1627          elsif Ekind (Id) = E_Incomplete_Type
1628            and then No (Full_View (Id))
1629          then
1630             --  Mark Taft amendment types
1631
1632             Set_Has_Completion_In_Body (Id);
1633
1634          elsif not Is_Child_Unit (Id)
1635            and then (not Is_Private_Type (Id)
1636                       or else No (Full_View (Id)))
1637          then
1638             Set_Is_Hidden (Id);
1639             Set_Is_Potentially_Use_Visible (Id, False);
1640          end if;
1641
1642          <<Next_Id>>
1643             Next_Entity (Id);
1644       end loop;
1645
1646    end Uninstall_Declarations;
1647
1648    ------------------------
1649    -- Unit_Requires_Body --
1650    ------------------------
1651
1652    function Unit_Requires_Body (P : Entity_Id) return Boolean is
1653       E : Entity_Id;
1654
1655    begin
1656       --  Imported entity never requires body. Right now, only
1657       --  subprograms can be imported, but perhaps in the future
1658       --  we will allow import of packages.
1659
1660       if Is_Imported (P) then
1661          return False;
1662
1663       --  Body required if library package with pragma Elaborate_Body
1664
1665       elsif Has_Pragma_Elaborate_Body (P) then
1666          return True;
1667
1668       --  Body required if subprogram
1669
1670       elsif (Is_Subprogram (P)
1671                or else
1672              Ekind (P) = E_Generic_Function
1673                or else
1674              Ekind (P) = E_Generic_Procedure)
1675       then
1676          return True;
1677
1678       --  Treat a block as requiring a body
1679
1680       elsif Ekind (P) = E_Block then
1681          return True;
1682
1683       elsif Ekind (P) = E_Package
1684         and then Nkind (Parent (P)) = N_Package_Specification
1685         and then Present (Generic_Parent (Parent (P)))
1686       then
1687          declare
1688             G_P : Entity_Id := Generic_Parent (Parent (P));
1689
1690          begin
1691             if Has_Pragma_Elaborate_Body (G_P) then
1692                return True;
1693             end if;
1694          end;
1695       end if;
1696
1697       --  Otherwise search entity chain for entity requiring completion.
1698
1699       E := First_Entity (P);
1700       while Present (E) loop
1701
1702          --  Always ignore child units. Child units get added to the entity
1703          --  list of a parent unit, but are not original entities of the
1704          --  parent, and so do not affect whether the parent needs a body.
1705
1706          if Is_Child_Unit (E) then
1707             null;
1708
1709          --  Otherwise test to see if entity requires a completion
1710
1711          elsif (Is_Overloadable (E)
1712                and then Ekind (E) /= E_Enumeration_Literal
1713                and then Ekind (E) /= E_Operator
1714                and then not Is_Abstract (E)
1715                and then not Has_Completion (E))
1716
1717            or else
1718              (Ekind (E) = E_Package
1719                and then E /= P
1720                and then not Has_Completion (E)
1721                and then Unit_Requires_Body (E))
1722
1723            or else
1724              (Ekind (E) = E_Incomplete_Type and then No (Full_View (E)))
1725
1726            or else
1727             ((Ekind (E) = E_Task_Type or else
1728               Ekind (E) = E_Protected_Type)
1729                and then not Has_Completion (E))
1730
1731            or else
1732              (Ekind (E) = E_Generic_Package and then E /= P
1733                and then not Has_Completion (E)
1734                and then Unit_Requires_Body (E))
1735
1736            or else
1737              (Ekind (E) = E_Generic_Function
1738                and then not Has_Completion (E))
1739
1740            or else
1741              (Ekind (E) = E_Generic_Procedure
1742                and then not Has_Completion (E))
1743
1744          then
1745             return True;
1746
1747          --  Entity that does not require completion
1748
1749          else
1750             null;
1751          end if;
1752
1753          Next_Entity (E);
1754       end loop;
1755
1756       return False;
1757    end Unit_Requires_Body;
1758
1759 end Sem_Ch7;