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