File : sem_cat.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ C A T                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25 
  26 with Atree;    use Atree;
  27 with Debug;    use Debug;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Exp_Disp; use Exp_Disp;
  32 with Fname;    use Fname;
  33 with Lib;      use Lib;
  34 with Namet;    use Namet;
  35 with Nlists;   use Nlists;
  36 with Opt;      use Opt;
  37 with Sem;      use Sem;
  38 with Sem_Attr; use Sem_Attr;
  39 with Sem_Aux;  use Sem_Aux;
  40 with Sem_Dist; use Sem_Dist;
  41 with Sem_Eval; use Sem_Eval;
  42 with Sem_Util; use Sem_Util;
  43 with Sinfo;    use Sinfo;
  44 with Snames;   use Snames;
  45 with Stand;    use Stand;
  46 
  47 package body Sem_Cat is
  48 
  49    -----------------------
  50    -- Local Subprograms --
  51    -----------------------
  52 
  53    procedure Check_Categorization_Dependencies
  54      (Unit_Entity     : Entity_Id;
  55       Depended_Entity : Entity_Id;
  56       Info_Node       : Node_Id;
  57       Is_Subunit      : Boolean);
  58    --  This procedure checks that the categorization of a lib unit and that
  59    --  of the depended unit satisfy dependency restrictions.
  60    --  The depended_entity can be the entity in a with_clause item, in which
  61    --  case Info_Node denotes that item. The depended_entity can also be the
  62    --  parent unit of a child unit, in which case Info_Node is the declaration
  63    --  of the child unit.  The error message is posted on Info_Node, and is
  64    --  specialized if Is_Subunit is true.
  65 
  66    procedure Check_Non_Static_Default_Expr
  67      (Type_Def : Node_Id;
  68       Obj_Decl : Node_Id);
  69    --  Iterate through the component list of a record definition, check
  70    --  that no component is declared with a nonstatic default value.
  71    --  If a nonstatic default exists, report an error on Obj_Decl.
  72 
  73    function Has_Read_Write_Attributes (E : Entity_Id) return Boolean;
  74    --  Return True if entity has attribute definition clauses for Read and
  75    --  Write attributes that are visible at some place.
  76 
  77    function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean;
  78    --  Returns true if the entity is a type whose full view is a non-remote
  79    --  access type, for the purpose of enforcing E.2.2(8) rules.
  80 
  81    function Has_Non_Remote_Access (Typ : Entity_Id) return Boolean;
  82    --  Return true if Typ or the type of any of its subcomponents is a non
  83    --  remote access type and doesn't have user-defined stream attributes.
  84 
  85    function No_External_Streaming (E : Entity_Id) return Boolean;
  86    --  Return True if the entity or one of its subcomponents does not support
  87    --  external streaming.
  88 
  89    function In_RCI_Declaration return Boolean;
  90    function In_RT_Declaration return Boolean;
  91    --  Determine if current scope is within the declaration of a Remote Call
  92    --  Interface or Remote Types unit, for semantic checking purposes.
  93 
  94    function In_Package_Declaration return Boolean;
  95    --  Shared supporting routine for In_RCI_Declaration and In_RT_Declaration
  96 
  97    function In_Shared_Passive_Unit return Boolean;
  98    --  Determines if current scope is within a Shared Passive compilation unit
  99 
 100    function Static_Discriminant_Expr (L : List_Id) return Boolean;
 101    --  Iterate through the list of discriminants to check if any of them
 102    --  contains non-static default expression, which is a violation in
 103    --  a preelaborated library unit.
 104 
 105    procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id);
 106    --  Check validity of declaration if RCI or RT unit. It should not contain
 107    --  the declaration of an access-to-object type unless it is a general
 108    --  access type that designates a class-wide limited private type. There are
 109    --  also constraints about the primitive subprograms of the class-wide type.
 110    --  RM E.2 (9, 13, 14)
 111 
 112    procedure Validate_RACW_Primitive
 113      (Subp : Entity_Id;
 114       RACW : Entity_Id);
 115    --  Check legality of the declaration of primitive Subp of the designated
 116    --  type of the given RACW type.
 117 
 118    ---------------------------------------
 119    -- Check_Categorization_Dependencies --
 120    ---------------------------------------
 121 
 122    procedure Check_Categorization_Dependencies
 123      (Unit_Entity     : Entity_Id;
 124       Depended_Entity : Entity_Id;
 125       Info_Node       : Node_Id;
 126       Is_Subunit      : Boolean)
 127    is
 128       N   : constant Node_Id := Info_Node;
 129       Err : Boolean;
 130 
 131       --  Here we define an enumeration type to represent categorization types,
 132       --  ordered so that a unit with a given categorization can only WITH
 133       --  units with lower or equal categorization type.
 134 
 135       type Categorization is
 136         (Pure,
 137          Shared_Passive,
 138          Remote_Types,
 139          Remote_Call_Interface,
 140          Normal);
 141 
 142       function Get_Categorization (E : Entity_Id) return Categorization;
 143       --  Check categorization flags from entity, and return in the form
 144       --  of the lowest value of the Categorization type that applies to E.
 145 
 146       ------------------------
 147       -- Get_Categorization --
 148       ------------------------
 149 
 150       function Get_Categorization (E : Entity_Id) return Categorization is
 151       begin
 152          --  Get the lowest categorization that corresponds to E. Note that
 153          --  nothing prevents several (different) categorization pragmas
 154          --  to apply to the same library unit, in which case the unit has
 155          --  all associated categories, so we need to be careful here to
 156          --  check pragmas in proper Categorization order in order to
 157          --  return the lowest applicable value.
 158 
 159          --  Ignore Pure specification if set by pragma Pure_Function
 160 
 161          if Is_Pure (E)
 162            and then not
 163             (Has_Pragma_Pure_Function (E) and not Has_Pragma_Pure (E))
 164          then
 165             return Pure;
 166 
 167          elsif Is_Shared_Passive (E) then
 168             return Shared_Passive;
 169 
 170          elsif Is_Remote_Types (E) then
 171             return Remote_Types;
 172 
 173          elsif Is_Remote_Call_Interface (E) then
 174             return Remote_Call_Interface;
 175 
 176          else
 177             return Normal;
 178          end if;
 179       end Get_Categorization;
 180 
 181       Unit_Category : Categorization;
 182       With_Category : Categorization;
 183 
 184    --  Start of processing for Check_Categorization_Dependencies
 185 
 186    begin
 187       --  Intrinsic subprograms are preelaborated, so do not impose any
 188       --  categorization dependencies. Also, ignore categorization
 189       --  dependencies when compilation switch -gnatdu is used.
 190 
 191       if Is_Intrinsic_Subprogram (Depended_Entity) or else Debug_Flag_U then
 192          return;
 193       end if;
 194 
 195       --  First check 10.2.1 (11/1) rules on preelaborate packages
 196 
 197       if Is_Preelaborated (Unit_Entity)
 198         and then not Is_Preelaborated (Depended_Entity)
 199         and then not Is_Pure (Depended_Entity)
 200       then
 201          Err := True;
 202       else
 203          Err := False;
 204       end if;
 205 
 206       --  Check categorization rules of RM E.2(5)
 207 
 208       Unit_Category := Get_Categorization (Unit_Entity);
 209       With_Category := Get_Categorization (Depended_Entity);
 210 
 211       if With_Category > Unit_Category then
 212 
 213          --  Special case: Remote_Types and Remote_Call_Interface are allowed
 214          --  to WITH anything in the package body, per (RM E.2(5)).
 215 
 216          if (Unit_Category = Remote_Types
 217               or else Unit_Category = Remote_Call_Interface)
 218            and then In_Package_Body (Unit_Entity)
 219          then
 220             null;
 221 
 222          --  Special case: Remote_Types and Remote_Call_Interface declarations
 223          --  can depend on a preelaborated unit via a private with_clause, per
 224          --  AI05-0206.
 225 
 226          elsif (Unit_Category = Remote_Types
 227                   or else
 228                 Unit_Category = Remote_Call_Interface)
 229            and then Nkind (N) = N_With_Clause
 230            and then Private_Present (N)
 231            and then Is_Preelaborated (Depended_Entity)
 232          then
 233             null;
 234 
 235          --  All other cases, we do have an error
 236 
 237          else
 238             Err := True;
 239          end if;
 240       end if;
 241 
 242       --  Here if we have an error
 243 
 244       if Err then
 245 
 246          --  These messages are warnings in GNAT mode or if the -gnateP switch
 247          --  was set. Otherwise these are real errors for real illegalities.
 248 
 249          --  The reason we suppress these errors in GNAT mode is that the run-
 250          --  time has several instances of violations of the categorization
 251          --  errors (e.g. Pure units withing Preelaborate units. All these
 252          --  violations are harmless in the cases where we intend them, and
 253          --  we suppress the warnings with Warnings (Off). In cases where we
 254          --  do not intend the violation, warnings are errors in GNAT mode
 255          --  anyway, so we will still get an error.
 256 
 257          Error_Msg_Warn :=
 258            Treat_Categorization_Errors_As_Warnings or GNAT_Mode;
 259 
 260          --  Don't give error if main unit is not an internal unit, and the
 261          --  unit generating the message is an internal unit. This is the
 262          --  situation in which such messages would be ignored in any case,
 263          --  so it is convenient not to generate them (since it causes
 264          --  annoying interference with debugging).
 265 
 266          if Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
 267            and then not Is_Internal_File_Name (Unit_File_Name (Main_Unit))
 268          then
 269             return;
 270 
 271          --  Dependence of Remote_Types or Remote_Call_Interface declaration
 272          --  on a preelaborated unit with a normal with_clause.
 273 
 274          elsif (Unit_Category = Remote_Types
 275                   or else
 276                 Unit_Category = Remote_Call_Interface)
 277            and then Is_Preelaborated (Depended_Entity)
 278          then
 279             Error_Msg_NE
 280               ("<<must use private with clause for preelaborated unit& ",
 281                N, Depended_Entity);
 282 
 283          --  Subunit case
 284 
 285          elsif Is_Subunit then
 286             Error_Msg_NE
 287               ("<subunit cannot depend on& " &
 288                "(parent has wrong categorization)", N, Depended_Entity);
 289 
 290          --  Normal unit, not subunit
 291 
 292          else
 293             Error_Msg_NE
 294               ("<<cannot depend on& " &
 295                "(wrong categorization)", N, Depended_Entity);
 296          end if;
 297 
 298          --  Add further explanation for Pure/Preelaborate common cases
 299 
 300          if Unit_Category = Pure then
 301             Error_Msg_NE
 302               ("\<<pure unit cannot depend on non-pure unit",
 303                N, Depended_Entity);
 304 
 305          elsif Is_Preelaborated (Unit_Entity)
 306            and then not Is_Preelaborated (Depended_Entity)
 307            and then not Is_Pure (Depended_Entity)
 308          then
 309             Error_Msg_NE
 310               ("\<<preelaborated unit cannot depend on "
 311                & "non-preelaborated unit",
 312                N, Depended_Entity);
 313          end if;
 314       end if;
 315    end Check_Categorization_Dependencies;
 316 
 317    -----------------------------------
 318    -- Check_Non_Static_Default_Expr --
 319    -----------------------------------
 320 
 321    procedure Check_Non_Static_Default_Expr
 322      (Type_Def : Node_Id;
 323       Obj_Decl : Node_Id)
 324    is
 325       Recdef         : Node_Id;
 326       Component_Decl : Node_Id;
 327 
 328    begin
 329       if Nkind (Type_Def) = N_Derived_Type_Definition then
 330          Recdef := Record_Extension_Part (Type_Def);
 331 
 332          if No (Recdef) then
 333             return;
 334          end if;
 335 
 336       else
 337          Recdef := Type_Def;
 338       end if;
 339 
 340       --  Check that component declarations do not involve:
 341 
 342       --    a. a non-static default expression, where the object is
 343       --       declared to be default initialized.
 344 
 345       --    b. a dynamic Itype (discriminants and constraints)
 346 
 347       if Null_Present (Recdef) then
 348          return;
 349       else
 350          Component_Decl := First (Component_Items (Component_List (Recdef)));
 351       end if;
 352 
 353       while Present (Component_Decl)
 354         and then Nkind (Component_Decl) = N_Component_Declaration
 355       loop
 356          if Present (Expression (Component_Decl))
 357            and then Nkind (Expression (Component_Decl)) /= N_Null
 358            and then not Is_OK_Static_Expression (Expression (Component_Decl))
 359          then
 360             Error_Msg_Sloc := Sloc (Component_Decl);
 361             Error_Msg_F
 362               ("object in preelaborated unit has non-static default#",
 363                Obj_Decl);
 364 
 365          --  Fix this later ???
 366 
 367          --  elsif Has_Dynamic_Itype (Component_Decl) then
 368          --     Error_Msg_N
 369          --       ("dynamic type discriminant," &
 370          --        " constraint in preelaborated unit",
 371          --        Component_Decl);
 372          end if;
 373 
 374          Next (Component_Decl);
 375       end loop;
 376    end Check_Non_Static_Default_Expr;
 377 
 378    ---------------------------
 379    -- Has_Non_Remote_Access --
 380    ---------------------------
 381 
 382    function Has_Non_Remote_Access (Typ : Entity_Id) return Boolean is
 383       Component : Entity_Id;
 384       Comp_Type : Entity_Id;
 385       U_Typ     : constant Entity_Id := Underlying_Type (Typ);
 386 
 387    begin
 388       if No (U_Typ) then
 389          return False;
 390 
 391       elsif Has_Read_Write_Attributes (Typ)
 392         or else Has_Read_Write_Attributes (U_Typ)
 393       then
 394          return False;
 395 
 396       elsif Is_Non_Remote_Access_Type (U_Typ) then
 397          return True;
 398       end if;
 399 
 400       if Is_Record_Type (U_Typ) then
 401          Component := First_Entity (U_Typ);
 402          while Present (Component) loop
 403             if not Is_Tag (Component) then
 404                Comp_Type := Etype (Component);
 405 
 406                if Has_Non_Remote_Access (Comp_Type) then
 407                   return True;
 408                end if;
 409             end if;
 410 
 411             Next_Entity (Component);
 412          end loop;
 413 
 414       elsif Is_Array_Type (U_Typ) then
 415          return Has_Non_Remote_Access (Component_Type (U_Typ));
 416 
 417       end if;
 418 
 419       return False;
 420    end Has_Non_Remote_Access;
 421 
 422    -------------------------------
 423    -- Has_Read_Write_Attributes --
 424    -------------------------------
 425 
 426    function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
 427    begin
 428       return True
 429         and then Has_Stream_Attribute_Definition
 430                    (E, TSS_Stream_Read,  At_Any_Place => True)
 431         and then Has_Stream_Attribute_Definition
 432                    (E, TSS_Stream_Write, At_Any_Place => True);
 433    end Has_Read_Write_Attributes;
 434 
 435    -------------------------------------
 436    -- Has_Stream_Attribute_Definition --
 437    -------------------------------------
 438 
 439    function Has_Stream_Attribute_Definition
 440      (Typ          : Entity_Id;
 441       Nam          : TSS_Name_Type;
 442       At_Any_Place : Boolean := False) return Boolean
 443    is
 444       Rep_Item : Node_Id;
 445 
 446       Real_Rep : Node_Id;
 447       --  The stream operation may be specified by an attribute definition
 448       --  clause in the source, or by an aspect that generates such an
 449       --  attribute definition. For an aspect, the generated attribute
 450       --  definition may be placed at the freeze point of the full view of
 451       --  the type, but the aspect specification makes the operation visible
 452       --  to a client wherever the partial view is visible.
 453 
 454    begin
 455       --  We start from the declaration node and then loop until the end of
 456       --  the list until we find the requested attribute definition clause.
 457       --  In Ada 2005 mode, clauses are ignored if they are not currently
 458       --  visible (this is tested using the corresponding Entity, which is
 459       --  inserted by the expander at the point where the clause occurs),
 460       --  unless At_Any_Place is true.
 461 
 462       Rep_Item := First_Rep_Item (Typ);
 463       while Present (Rep_Item) loop
 464          Real_Rep := Rep_Item;
 465 
 466          --  If the representation item is an aspect specification, retrieve
 467          --  the corresponding pragma or attribute definition.
 468 
 469          if Nkind (Rep_Item) = N_Aspect_Specification then
 470             Real_Rep := Aspect_Rep_Item (Rep_Item);
 471          end if;
 472 
 473          if Nkind (Real_Rep) = N_Attribute_Definition_Clause then
 474             case Chars (Real_Rep) is
 475                when Name_Read =>
 476                   exit when Nam = TSS_Stream_Read;
 477 
 478                when Name_Write =>
 479                   exit when Nam = TSS_Stream_Write;
 480 
 481                when Name_Input =>
 482                   exit when Nam = TSS_Stream_Input;
 483 
 484                when Name_Output =>
 485                   exit when Nam = TSS_Stream_Output;
 486 
 487                when others =>
 488                   null;
 489 
 490             end case;
 491          end if;
 492 
 493          Next_Rep_Item (Rep_Item);
 494       end loop;
 495 
 496       --  If not found, and the type is derived from a private view, check
 497       --  for a stream attribute inherited from parent. Any specified stream
 498       --  attributes will be attached to the derived type's underlying type
 499       --  rather the derived type entity itself (which is itself private).
 500 
 501       if No (Rep_Item)
 502         and then Is_Private_Type (Typ)
 503         and then Is_Derived_Type (Typ)
 504         and then Present (Full_View (Typ))
 505       then
 506          return Has_Stream_Attribute_Definition
 507             (Underlying_Type (Typ), Nam, At_Any_Place);
 508 
 509       --  Otherwise, if At_Any_Place is true, return True if the attribute is
 510       --  available at any place; if it is false, return True only if the
 511       --  attribute is currently visible.
 512 
 513       else
 514          return Present (Rep_Item)
 515            and then (Ada_Version < Ada_2005
 516                       or else At_Any_Place
 517                       or else not Is_Hidden (Entity (Rep_Item)));
 518       end if;
 519    end Has_Stream_Attribute_Definition;
 520 
 521    ----------------------------
 522    -- In_Package_Declaration --
 523    ----------------------------
 524 
 525    function In_Package_Declaration return Boolean is
 526       Unit_Kind   : constant Node_Kind :=
 527                       Nkind (Unit (Cunit (Current_Sem_Unit)));
 528 
 529    begin
 530       --  There are no restrictions on the body of an RCI or RT unit
 531 
 532       return Is_Package_Or_Generic_Package (Current_Scope)
 533         and then Unit_Kind /= N_Package_Body
 534         and then not In_Package_Body (Current_Scope)
 535         and then not In_Instance;
 536    end In_Package_Declaration;
 537 
 538    ---------------------------
 539    -- In_Preelaborated_Unit --
 540    ---------------------------
 541 
 542    function In_Preelaborated_Unit return Boolean is
 543       Unit_Entity : Entity_Id := Current_Scope;
 544       Unit_Kind   : constant Node_Kind :=
 545                       Nkind (Unit (Cunit (Current_Sem_Unit)));
 546 
 547    begin
 548       --  If evaluating actuals for a child unit instantiation, then ignore
 549       --  the preelaboration status of the parent; use the child instead.
 550 
 551       if Is_Compilation_Unit (Unit_Entity)
 552         and then Unit_Kind in N_Generic_Instantiation
 553         and then not In_Same_Source_Unit (Unit_Entity,
 554                                           Cunit (Current_Sem_Unit))
 555       then
 556          Unit_Entity := Cunit_Entity (Current_Sem_Unit);
 557       end if;
 558 
 559       --  There are no constraints on the body of Remote_Call_Interface or
 560       --  Remote_Types packages.
 561 
 562       return (Unit_Entity /= Standard_Standard)
 563         and then (Is_Preelaborated (Unit_Entity)
 564                     or else Is_Pure (Unit_Entity)
 565                     or else Is_Shared_Passive (Unit_Entity)
 566                     or else
 567                       ((Is_Remote_Types (Unit_Entity)
 568                           or else Is_Remote_Call_Interface (Unit_Entity))
 569                          and then Ekind (Unit_Entity) = E_Package
 570                          and then Unit_Kind /= N_Package_Body
 571                          and then not In_Package_Body (Unit_Entity)
 572                          and then not In_Instance));
 573    end In_Preelaborated_Unit;
 574 
 575    ------------------
 576    -- In_Pure_Unit --
 577    ------------------
 578 
 579    function In_Pure_Unit return Boolean is
 580    begin
 581       return Is_Pure (Current_Scope);
 582    end In_Pure_Unit;
 583 
 584    ------------------------
 585    -- In_RCI_Declaration --
 586    ------------------------
 587 
 588    function In_RCI_Declaration return Boolean is
 589    begin
 590       return Is_Remote_Call_Interface (Current_Scope)
 591         and then In_Package_Declaration;
 592    end In_RCI_Declaration;
 593 
 594    -----------------------
 595    -- In_RT_Declaration --
 596    -----------------------
 597 
 598    function In_RT_Declaration return Boolean is
 599    begin
 600       return Is_Remote_Types (Current_Scope) and then In_Package_Declaration;
 601    end In_RT_Declaration;
 602 
 603    ----------------------------
 604    -- In_Shared_Passive_Unit --
 605    ----------------------------
 606 
 607    function In_Shared_Passive_Unit return Boolean is
 608       Unit_Entity : constant Entity_Id := Current_Scope;
 609 
 610    begin
 611       return Is_Shared_Passive (Unit_Entity);
 612    end In_Shared_Passive_Unit;
 613 
 614    ---------------------------------------
 615    -- In_Subprogram_Task_Protected_Unit --
 616    ---------------------------------------
 617 
 618    function In_Subprogram_Task_Protected_Unit return Boolean is
 619       E : Entity_Id;
 620 
 621    begin
 622       --  The following is to verify that a declaration is inside
 623       --  subprogram, generic subprogram, task unit, protected unit.
 624       --  Used to validate if a lib. unit is Pure. RM 10.2.1(16).
 625 
 626       --  Use scope chain to check successively outer scopes
 627 
 628       E := Current_Scope;
 629       loop
 630          if Is_Subprogram_Or_Generic_Subprogram (E)
 631               or else
 632             Is_Concurrent_Type (E)
 633          then
 634             return True;
 635 
 636          elsif E = Standard_Standard then
 637             return False;
 638          end if;
 639 
 640          E := Scope (E);
 641       end loop;
 642    end In_Subprogram_Task_Protected_Unit;
 643 
 644    -------------------------------
 645    -- Is_Non_Remote_Access_Type --
 646    -------------------------------
 647 
 648    function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean is
 649       U_E : constant Entity_Id := Underlying_Type (Base_Type (E));
 650       --  Use full view of base type to handle subtypes properly.
 651 
 652    begin
 653       if No (U_E) then
 654 
 655          --  This case arises for the case of a generic formal type, in which
 656          --  case E.2.2(8) rules will be enforced at instantiation time.
 657 
 658          return False;
 659       end if;
 660 
 661       return Is_Access_Type (U_E)
 662         and then not Is_Remote_Access_To_Class_Wide_Type (U_E)
 663         and then not Is_Remote_Access_To_Subprogram_Type (U_E);
 664    end Is_Non_Remote_Access_Type;
 665 
 666    ---------------------------
 667    -- No_External_Streaming --
 668    ---------------------------
 669 
 670    function No_External_Streaming (E : Entity_Id) return Boolean is
 671       U_E : constant Entity_Id := Underlying_Type (E);
 672 
 673    begin
 674       if No (U_E) then
 675          return False;
 676 
 677       elsif Has_Read_Write_Attributes (E) then
 678 
 679          --  Note: availability of stream attributes is tested on E, not U_E.
 680          --  There may be stream attributes defined on U_E that are not visible
 681          --  at the place where support of external streaming is tested.
 682 
 683          return False;
 684 
 685       elsif Has_Non_Remote_Access (U_E) then
 686          return True;
 687       end if;
 688 
 689       return Is_Limited_Type (E);
 690    end No_External_Streaming;
 691 
 692    -------------------------------------
 693    -- Set_Categorization_From_Pragmas --
 694    -------------------------------------
 695 
 696    procedure Set_Categorization_From_Pragmas (N : Node_Id) is
 697       P   : constant Node_Id := Parent (N);
 698       S   : constant Entity_Id := Current_Scope;
 699 
 700       procedure Set_Parents (Visibility : Boolean);
 701          --  If this is a child instance, the parents are not immediately
 702          --  visible during analysis. Make them momentarily visible so that
 703          --  the argument of the pragma can be resolved properly, and reset
 704          --  afterwards.
 705 
 706       -----------------
 707       -- Set_Parents --
 708       -----------------
 709 
 710       procedure Set_Parents (Visibility : Boolean) is
 711          Par : Entity_Id;
 712       begin
 713          Par := Scope (S);
 714          while Present (Par) and then Par /= Standard_Standard loop
 715             Set_Is_Immediately_Visible (Par, Visibility);
 716             Par := Scope (Par);
 717          end loop;
 718       end Set_Parents;
 719 
 720    --  Start of processing for Set_Categorization_From_Pragmas
 721 
 722    begin
 723       --  Deal with categorization pragmas in Pragmas of Compilation_Unit.
 724       --  The purpose is to set categorization flags before analyzing the
 725       --  unit itself, so as to diagnose violations of categorization as
 726       --  we process each declaration, even though the pragma appears after
 727       --  the unit.
 728 
 729       if Nkind (P) /= N_Compilation_Unit then
 730          return;
 731       end if;
 732 
 733       declare
 734          PN : Node_Id;
 735 
 736       begin
 737          if Is_Child_Unit (S) and then Is_Generic_Instance (S) then
 738             Set_Parents (True);
 739          end if;
 740 
 741          PN := First (Pragmas_After (Aux_Decls_Node (P)));
 742          while Present (PN) loop
 743 
 744             --  Skip implicit types that may have been introduced by
 745             --  previous analysis.
 746 
 747             if Nkind (PN) = N_Pragma then
 748                case Get_Pragma_Id (PN) is
 749                   when Pragma_All_Calls_Remote   |
 750                     Pragma_Preelaborate          |
 751                     Pragma_Pure                  |
 752                     Pragma_Remote_Call_Interface |
 753                     Pragma_Remote_Types          |
 754                     Pragma_Shared_Passive        => Analyze (PN);
 755                   when others                    => null;
 756                end case;
 757             end if;
 758 
 759             Next (PN);
 760          end loop;
 761 
 762          if Is_Child_Unit (S) and then Is_Generic_Instance (S) then
 763             Set_Parents (False);
 764          end if;
 765       end;
 766    end Set_Categorization_From_Pragmas;
 767 
 768    -----------------------------------
 769    -- Set_Categorization_From_Scope --
 770    -----------------------------------
 771 
 772    procedure Set_Categorization_From_Scope (E : Entity_Id; Scop : Entity_Id) is
 773       Declaration   : Node_Id := Empty;
 774       Specification : Node_Id := Empty;
 775 
 776    begin
 777       Set_Is_Pure
 778         (E, Is_Pure (Scop) and then Is_Library_Level_Entity (E));
 779 
 780       if not Is_Remote_Call_Interface (E) then
 781          if Ekind (E) in Subprogram_Kind then
 782             Declaration := Unit_Declaration_Node (E);
 783 
 784             if Nkind_In (Declaration, N_Subprogram_Body,
 785                                       N_Subprogram_Renaming_Declaration)
 786             then
 787                Specification := Corresponding_Spec (Declaration);
 788             end if;
 789          end if;
 790 
 791          --  A subprogram body or renaming-as-body is a remote call interface
 792          --  if it serves as the completion of a subprogram declaration that
 793          --  is a remote call interface.
 794 
 795          if Nkind (Specification) in N_Entity then
 796             Set_Is_Remote_Call_Interface
 797               (E, Is_Remote_Call_Interface (Specification));
 798 
 799          --  A subprogram declaration is a remote call interface when it is
 800          --  declared within the visible part of, or declared by, a library
 801          --  unit declaration that is a remote call interface.
 802 
 803          else
 804             Set_Is_Remote_Call_Interface
 805               (E, Is_Remote_Call_Interface (Scop)
 806                     and then not (In_Private_Part (Scop)
 807                                    or else In_Package_Body (Scop)));
 808          end if;
 809       end if;
 810 
 811       Set_Is_Remote_Types
 812         (E, Is_Remote_Types (Scop)
 813               and then not (In_Private_Part (Scop)
 814                              or else In_Package_Body (Scop)));
 815    end Set_Categorization_From_Scope;
 816 
 817    ------------------------------
 818    -- Static_Discriminant_Expr --
 819    ------------------------------
 820 
 821    --  We need to accommodate a Why_Not_Static call somehow here ???
 822 
 823    function Static_Discriminant_Expr (L : List_Id) return Boolean is
 824       Discriminant_Spec : Node_Id;
 825 
 826    begin
 827       Discriminant_Spec := First (L);
 828       while Present (Discriminant_Spec) loop
 829          if Present (Expression (Discriminant_Spec))
 830            and then
 831              not Is_OK_Static_Expression (Expression (Discriminant_Spec))
 832          then
 833             return False;
 834          end if;
 835 
 836          Next (Discriminant_Spec);
 837       end loop;
 838 
 839       return True;
 840    end Static_Discriminant_Expr;
 841 
 842    --------------------------------------
 843    -- Validate_Access_Type_Declaration --
 844    --------------------------------------
 845 
 846    procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id) is
 847       Def : constant Node_Id := Type_Definition (N);
 848 
 849    begin
 850       case Nkind (Def) is
 851 
 852          --  Access to subprogram case
 853 
 854          when N_Access_To_Subprogram_Definition =>
 855 
 856             --  A pure library_item must not contain the declaration of a
 857             --  named access type, except within a subprogram, generic
 858             --  subprogram, task unit, or protected unit (RM 10.2.1(16)).
 859 
 860             --  This test is skipped in Ada 2005 (see AI-366)
 861 
 862             if Ada_Version < Ada_2005
 863               and then Comes_From_Source (T)
 864               and then In_Pure_Unit
 865               and then not In_Subprogram_Task_Protected_Unit
 866             then
 867                Error_Msg_N ("named access type not allowed in pure unit", T);
 868             end if;
 869 
 870          --  Access to object case
 871 
 872          when N_Access_To_Object_Definition =>
 873             if Comes_From_Source (T)
 874               and then In_Pure_Unit
 875               and then not In_Subprogram_Task_Protected_Unit
 876             then
 877                --  We can't give the message yet, since the type is not frozen
 878                --  and in Ada 2005 mode, access types are allowed in pure units
 879                --  if the type has no storage pool (see AI-366). So we set a
 880                --  flag which will be checked at freeze time.
 881 
 882                Set_Is_Pure_Unit_Access_Type (T);
 883             end if;
 884 
 885             --  Check for RCI or RT unit type declaration: declaration of an
 886             --  access-to-object type is illegal unless it is a general access
 887             --  type that designates a class-wide limited private type.
 888             --  Note that constraints on the primitive subprograms of the
 889             --  designated tagged type are not enforced here but in
 890             --  Validate_RACW_Primitives, which is done separately because the
 891             --  designated type might not be frozen (and therefore its
 892             --  primitive operations might not be completely known) at the
 893             --  point of the RACW declaration.
 894 
 895             Validate_Remote_Access_Object_Type_Declaration (T);
 896 
 897             --  Check for shared passive unit type declaration. It should
 898             --  not contain the declaration of access to class wide type,
 899             --  access to task type and access to protected type with entry.
 900 
 901             Validate_SP_Access_Object_Type_Decl (T);
 902 
 903          when others =>
 904             null;
 905       end case;
 906 
 907       --  Set categorization flag from package on entity as well, to allow
 908       --  easy checks later on for required validations of RCI or RT units.
 909       --  This is only done for entities that are in the original source.
 910 
 911       if Comes_From_Source (T)
 912         and then not (In_Package_Body (Scope (T))
 913                        or else In_Private_Part (Scope (T)))
 914       then
 915          Set_Is_Remote_Call_Interface
 916            (T, Is_Remote_Call_Interface (Scope (T)));
 917          Set_Is_Remote_Types
 918            (T, Is_Remote_Types (Scope (T)));
 919       end if;
 920    end Validate_Access_Type_Declaration;
 921 
 922    ----------------------------
 923    -- Validate_Ancestor_Part --
 924    ----------------------------
 925 
 926    procedure Validate_Ancestor_Part (N : Node_Id) is
 927       A : constant Node_Id   := Ancestor_Part (N);
 928       T : constant Entity_Id := Entity (A);
 929 
 930    begin
 931       if In_Preelaborated_Unit
 932         and then not In_Subprogram_Or_Concurrent_Unit
 933         and then (not Inside_A_Generic
 934                    or else Present (Enclosing_Generic_Body (N)))
 935       then
 936          --  If the type is private, it must have the Ada 2005 pragma
 937          --  Has_Preelaborable_Initialization.
 938 
 939          --  The check is omitted within predefined units. This is probably
 940          --  obsolete code to fix the Ada 95 weakness in this area ???
 941 
 942          if Is_Private_Type (T)
 943            and then not Has_Pragma_Preelab_Init (T)
 944            and then not Is_Internal_File_Name
 945                           (Unit_File_Name (Get_Source_Unit (N)))
 946          then
 947             Error_Msg_N
 948               ("private ancestor type not allowed in preelaborated unit", A);
 949 
 950          elsif Is_Record_Type (T) then
 951             if Nkind (Parent (T)) = N_Full_Type_Declaration then
 952                Check_Non_Static_Default_Expr
 953                  (Type_Definition (Parent (T)), A);
 954             end if;
 955          end if;
 956       end if;
 957    end Validate_Ancestor_Part;
 958 
 959    ----------------------------------------
 960    -- Validate_Categorization_Dependency --
 961    ----------------------------------------
 962 
 963    procedure Validate_Categorization_Dependency
 964      (N : Node_Id;
 965       E : Entity_Id)
 966    is
 967       K          : constant Node_Kind := Nkind (N);
 968       P          : Node_Id            := Parent (N);
 969       U          : Entity_Id := E;
 970       Is_Subunit : constant Boolean := Nkind (P) = N_Subunit;
 971 
 972    begin
 973       --  Only validate library units and subunits. For subunits, checks
 974       --  concerning withed units apply to the parent compilation unit.
 975 
 976       if Is_Subunit then
 977          P := Parent (P);
 978          U := Scope (E);
 979 
 980          while Present (U)
 981            and then not Is_Compilation_Unit (U)
 982            and then not Is_Child_Unit (U)
 983          loop
 984             U := Scope (U);
 985          end loop;
 986       end if;
 987 
 988       if Nkind (P) /= N_Compilation_Unit then
 989          return;
 990       end if;
 991 
 992       --  Body of RCI unit does not need validation
 993 
 994       if Is_Remote_Call_Interface (E)
 995         and then Nkind_In (N, N_Package_Body, N_Subprogram_Body)
 996       then
 997          return;
 998       end if;
 999 
1000       --  Ada 2005 (AI-50217): Process explicit non-limited with_clauses
1001 
1002       declare
1003          Item             : Node_Id;
1004          Entity_Of_Withed : Entity_Id;
1005 
1006       begin
1007          Item := First (Context_Items (P));
1008          while Present (Item) loop
1009             if Nkind (Item) = N_With_Clause
1010               and then not (Implicit_With (Item)
1011                              or else Limited_Present (Item)
1012 
1013                              --  Skip if error already posted on the WITH
1014                              --  clause (in which case the Name attribute
1015                              --  may be invalid). In particular, this fixes
1016                              --  the problem of hanging in the presence of a
1017                              --  WITH clause on a child that is an illegal
1018                              --  generic instantiation.
1019 
1020                              or else Error_Posted (Item))
1021             then
1022                Entity_Of_Withed := Entity (Name (Item));
1023                Check_Categorization_Dependencies
1024                  (U, Entity_Of_Withed, Item, Is_Subunit);
1025             end if;
1026 
1027             Next (Item);
1028          end loop;
1029       end;
1030 
1031       --  Child depends on parent; therefore parent should also be categorized
1032       --  and satisfy the dependency hierarchy.
1033 
1034       --  Check if N is a child spec
1035 
1036       if (K in N_Generic_Declaration              or else
1037           K in N_Generic_Instantiation            or else
1038           K in N_Generic_Renaming_Declaration     or else
1039           K =  N_Package_Declaration              or else
1040           K =  N_Package_Renaming_Declaration     or else
1041           K =  N_Subprogram_Declaration           or else
1042           K =  N_Subprogram_Renaming_Declaration)
1043         and then Present (Parent_Spec (N))
1044       then
1045          Check_Categorization_Dependencies (E, Scope (E), N, False);
1046 
1047          --  Verify that public child of an RCI library unit must also be an
1048          --  RCI library unit (RM E.2.3(15)).
1049 
1050          if Is_Remote_Call_Interface (Scope (E))
1051            and then not Private_Present (P)
1052            and then not Is_Remote_Call_Interface (E)
1053          then
1054             Error_Msg_N ("public child of rci unit must also be rci unit", N);
1055          end if;
1056       end if;
1057    end Validate_Categorization_Dependency;
1058 
1059    --------------------------------
1060    -- Validate_Controlled_Object --
1061    --------------------------------
1062 
1063    procedure Validate_Controlled_Object (E : Entity_Id) is
1064    begin
1065       --  Don't need this check in Ada 2005 mode, where this is all taken
1066       --  care of by the mechanism for Preelaborable Initialization.
1067 
1068       if Ada_Version >= Ada_2005 then
1069          return;
1070       end if;
1071 
1072       --  For now, never apply this check for internal GNAT units, since we
1073       --  have a number of cases in the library where we are stuck with objects
1074       --  of this type, and the RM requires Preelaborate.
1075 
1076       --  For similar reasons, we only do this check for source entities, since
1077       --  we generate entities of this type in some situations.
1078 
1079       --  Note that the 10.2.1(9) restrictions are not relevant to us anyway.
1080       --  We have to enforce them for RM compatibility, but we have no trouble
1081       --  accepting these objects and doing the right thing. Note that there is
1082       --  no requirement that Preelaborate not actually generate any code.
1083 
1084       if In_Preelaborated_Unit
1085         and then not Debug_Flag_PP
1086         and then Comes_From_Source (E)
1087         and then not
1088           Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (E)))
1089         and then (not Inside_A_Generic
1090                    or else Present (Enclosing_Generic_Body (E)))
1091         and then not Is_Protected_Type (Etype (E))
1092       then
1093          Error_Msg_N
1094            ("library level controlled object not allowed in " &
1095             "preelaborated unit", E);
1096       end if;
1097    end Validate_Controlled_Object;
1098 
1099    --------------------------------------
1100    -- Validate_Null_Statement_Sequence --
1101    --------------------------------------
1102 
1103    procedure Validate_Null_Statement_Sequence (N : Node_Id) is
1104       Item : Node_Id;
1105 
1106    begin
1107       if In_Preelaborated_Unit then
1108          Item := First (Statements (Handled_Statement_Sequence (N)));
1109          while Present (Item) loop
1110             if Nkind (Item) /= N_Label
1111               and then Nkind (Item) /= N_Null_Statement
1112             then
1113                --  In GNAT mode, this is a warning, allowing the run-time
1114                --  to judiciously bypass this error condition.
1115 
1116                Error_Msg_Warn := GNAT_Mode;
1117                Error_Msg_N
1118                  ("<<statements not allowed in preelaborated unit", Item);
1119 
1120                exit;
1121             end if;
1122 
1123             Next (Item);
1124          end loop;
1125       end if;
1126    end Validate_Null_Statement_Sequence;
1127 
1128    ---------------------------------
1129    -- Validate_Object_Declaration --
1130    ---------------------------------
1131 
1132    procedure Validate_Object_Declaration (N : Node_Id) is
1133       Id  : constant Entity_Id  := Defining_Identifier (N);
1134       E   : constant Node_Id    := Expression (N);
1135       Odf : constant Node_Id    := Object_Definition (N);
1136       T   : constant Entity_Id  := Etype (Id);
1137 
1138    begin
1139       --  Verify that any access to subprogram object does not have in its
1140       --  subprogram profile access type parameters or limited parameters
1141       --  without Read and Write attributes (E.2.3(13)).
1142 
1143       Validate_RCI_Subprogram_Declaration (N);
1144 
1145       --  Check that if we are in preelaborated elaboration code, then we
1146       --  do not have an instance of a default initialized private, task or
1147       --  protected object declaration which would violate (RM 10.2.1(9)).
1148       --  Note that constants are never default initialized (and the test
1149       --  below also filters out deferred constants). A variable is default
1150       --  initialized if it does *not* have an initialization expression.
1151 
1152       --  Filter out cases that are not declaration of a variable from source
1153 
1154       if Nkind (N) /= N_Object_Declaration
1155         or else Constant_Present (N)
1156         or else not Comes_From_Source (Id)
1157       then
1158          return;
1159       end if;
1160 
1161       --  Exclude generic specs from the checks (this will get rechecked
1162       --  on instantiations).
1163 
1164       if Inside_A_Generic and then No (Enclosing_Generic_Body (Id)) then
1165          return;
1166       end if;
1167 
1168       --  Required checks for declaration that is in a preelaborated package
1169       --  and is not within some subprogram.
1170 
1171       if In_Preelaborated_Unit
1172         and then not In_Subprogram_Or_Concurrent_Unit
1173       then
1174          --  Check for default initialized variable case. Note that in
1175          --  accordance with (RM B.1(24)) imported objects are not subject to
1176          --  default initialization.
1177          --  If the initialization does not come from source and is an
1178          --  aggregate, it is a static initialization that replaces an
1179          --  implicit call, and must be treated as such.
1180 
1181          if Present (E)
1182            and then (Comes_From_Source (E) or else Nkind (E) /= N_Aggregate)
1183          then
1184             null;
1185 
1186          elsif Is_Imported (Id) then
1187             null;
1188 
1189          else
1190             declare
1191                Ent : Entity_Id := T;
1192 
1193             begin
1194                --  An array whose component type is a record with nonstatic
1195                --  default expressions is a violation, so we get the array's
1196                --  component type.
1197 
1198                if Is_Array_Type (Ent) then
1199                   declare
1200                      Comp_Type : Entity_Id;
1201 
1202                   begin
1203                      Comp_Type := Component_Type (Ent);
1204                      while Is_Array_Type (Comp_Type) loop
1205                         Comp_Type := Component_Type (Comp_Type);
1206                      end loop;
1207 
1208                      Ent := Comp_Type;
1209                   end;
1210                end if;
1211 
1212                --  Object decl. that is of record type and has no default expr.
1213                --  should check if there is any non-static default expression
1214                --  in component decl. of the record type decl.
1215 
1216                if Is_Record_Type (Ent) then
1217                   if Nkind (Parent (Ent)) = N_Full_Type_Declaration then
1218                      Check_Non_Static_Default_Expr
1219                        (Type_Definition (Parent (Ent)), N);
1220 
1221                   elsif Nkind (Odf) = N_Subtype_Indication
1222                     and then not Is_Array_Type (T)
1223                     and then not Is_Private_Type (T)
1224                   then
1225                      Check_Non_Static_Default_Expr (Type_Definition
1226                        (Parent (Entity (Subtype_Mark (Odf)))), N);
1227                   end if;
1228                end if;
1229 
1230                --  Check for invalid use of private object. Note that Ada 2005
1231                --  AI-161 modifies the rules for Ada 2005, including the use of
1232                --  the new pragma Preelaborable_Initialization.
1233 
1234                if Is_Private_Type (Ent)
1235                  or else Depends_On_Private (Ent)
1236                then
1237                   --  Case where type has preelaborable initialization which
1238                   --  means that a pragma Preelaborable_Initialization was
1239                   --  given for the private type.
1240 
1241                   if Relaxed_RM_Semantics then
1242 
1243                      --  In relaxed mode, do not issue these messages, this
1244                      --  is basically similar to the GNAT_Mode test below.
1245 
1246                      null;
1247 
1248                   elsif Has_Preelaborable_Initialization (Ent) then
1249 
1250                      --  But for the predefined units, we will ignore this
1251                      --  status unless we are in Ada 2005 mode since we want
1252                      --  Ada 95 compatible behavior, in which the entities
1253                      --  marked with this pragma in the predefined library are
1254                      --  not treated specially.
1255 
1256                      if Ada_Version < Ada_2005 then
1257                         Error_Msg_N
1258                           ("private object not allowed in preelaborated unit",
1259                            N);
1260                         Error_Msg_N ("\(would be legal in Ada 2005 mode)", N);
1261                      end if;
1262 
1263                   --  Type does not have preelaborable initialization
1264 
1265                   else
1266                      --  We allow this when compiling in GNAT mode to make life
1267                      --  easier for some cases where it would otherwise be hard
1268                      --  to be exactly valid Ada.
1269 
1270                      if not GNAT_Mode then
1271                         Error_Msg_N
1272                           ("private object not allowed in preelaborated unit",
1273                            N);
1274 
1275                         --  Add a message if it would help to provide a pragma
1276                         --  Preelaborable_Initialization on the type of the
1277                         --  object (which would make it legal in Ada 2005).
1278 
1279                         --  If the type has no full view (generic type, or
1280                         --  previous error), the warning does not apply.
1281 
1282                         if Is_Private_Type (Ent)
1283                           and then Present (Full_View (Ent))
1284                           and then
1285                             Has_Preelaborable_Initialization (Full_View (Ent))
1286                         then
1287                            Error_Msg_Sloc := Sloc (Ent);
1288 
1289                            if Ada_Version >= Ada_2005 then
1290                               Error_Msg_NE
1291                                 ("\would be legal if pragma Preelaborable_" &
1292                                  "Initialization given for & #", N, Ent);
1293                            else
1294                               Error_Msg_NE
1295                                 ("\would be legal in Ada 2005 if pragma " &
1296                                  "Preelaborable_Initialization given for & #",
1297                                  N, Ent);
1298                            end if;
1299                         end if;
1300                      end if;
1301                   end if;
1302 
1303                --  Access to Task or Protected type
1304 
1305                elsif Is_Entity_Name (Odf)
1306                  and then Present (Etype (Odf))
1307                  and then Is_Access_Type (Etype (Odf))
1308                then
1309                   Ent := Designated_Type (Etype (Odf));
1310 
1311                elsif Is_Entity_Name (Odf) then
1312                   Ent := Entity (Odf);
1313 
1314                elsif Nkind (Odf) = N_Subtype_Indication then
1315                   Ent := Etype (Subtype_Mark (Odf));
1316 
1317                elsif Nkind (Odf) = N_Constrained_Array_Definition then
1318                   Ent := Component_Type (T);
1319                end if;
1320 
1321                if Is_Task_Type (Ent)
1322                  or else (Is_Protected_Type (Ent) and then Has_Entries (Ent))
1323                then
1324                   Error_Msg_N
1325                     ("concurrent object not allowed in preelaborated unit",
1326                      N);
1327                   return;
1328                end if;
1329             end;
1330          end if;
1331 
1332          --  Non-static discriminants not allowed in preelaborated unit.
1333          --  Objects of a controlled type with a user-defined Initialize
1334          --  are forbidden as well.
1335 
1336          if Is_Record_Type (Etype (Id)) then
1337             declare
1338                ET  : constant Entity_Id := Etype (Id);
1339                EE  : constant Entity_Id := Etype (Etype (Id));
1340                PEE : Node_Id;
1341 
1342             begin
1343                if Has_Discriminants (ET) and then Present (EE) then
1344                   PEE := Parent (EE);
1345 
1346                   if Nkind (PEE) = N_Full_Type_Declaration
1347                     and then not Static_Discriminant_Expr
1348                                    (Discriminant_Specifications (PEE))
1349                   then
1350                      Error_Msg_N
1351                        ("non-static discriminant in preelaborated unit",
1352                         PEE);
1353                   end if;
1354                end if;
1355 
1356                --  For controlled type or type with controlled component, check
1357                --  preelaboration flag, as there may be a non-null Initialize
1358                --  primitive. For language versions earlier than Ada 2005,
1359                --  there is no notion of preelaborable initialization, and
1360                --  Validate_Controlled_Object is used to enforce rules for
1361                --  controlled objects.
1362 
1363                if (Is_Controlled (ET) or else Has_Controlled_Component (ET))
1364                     and then Ada_Version >= Ada_2005
1365                     and then not Has_Preelaborable_Initialization (ET)
1366                then
1367                   Error_Msg_NE
1368                     ("controlled type& does not have"
1369                       & " preelaborable initialization", N, ET);
1370                end if;
1371             end;
1372 
1373          end if;
1374       end if;
1375 
1376       --  A pure library_item must not contain the declaration of any variable
1377       --  except within a subprogram, generic subprogram, task unit, or
1378       --  protected unit (RM 10.2.1(16)).
1379 
1380       if In_Pure_Unit and then not In_Subprogram_Task_Protected_Unit then
1381          Error_Msg_N ("declaration of variable not allowed in pure unit", N);
1382 
1383       elsif not In_Private_Part (Id) then
1384 
1385          --  The visible part of an RCI library unit must not contain the
1386          --  declaration of a variable (RM E.1.3(9)).
1387 
1388          if In_RCI_Declaration then
1389             Error_Msg_N ("visible variable not allowed in 'R'C'I unit", N);
1390 
1391          --  The visible part of a Shared Passive library unit must not contain
1392          --  the declaration of a variable (RM E.2.2(7)).
1393 
1394          elsif In_RT_Declaration then
1395             Error_Msg_N
1396               ("visible variable not allowed in remote types unit", N);
1397          end if;
1398       end if;
1399    end Validate_Object_Declaration;
1400 
1401    -----------------------------
1402    -- Validate_RACW_Primitive --
1403    -----------------------------
1404 
1405    procedure Validate_RACW_Primitive
1406      (Subp : Entity_Id;
1407       RACW : Entity_Id)
1408    is
1409       procedure Illegal_Remote_Subp (Msg : String; N : Node_Id);
1410       --  Diagnose illegality on N. If RACW is present, report the error on it
1411       --  rather than on N.
1412 
1413       -------------------------
1414       -- Illegal_Remote_Subp --
1415       -------------------------
1416 
1417       procedure Illegal_Remote_Subp (Msg : String; N : Node_Id) is
1418       begin
1419          if Present (RACW) then
1420             if not Error_Posted (RACW) then
1421                Error_Msg_N
1422                  ("illegal remote access to class-wide type&", RACW);
1423             end if;
1424 
1425             Error_Msg_Sloc := Sloc (N);
1426             Error_Msg_NE ("\\" & Msg & " in primitive& #", RACW, Subp);
1427 
1428          else
1429             Error_Msg_NE (Msg & " in remote subprogram&", N, Subp);
1430          end if;
1431       end Illegal_Remote_Subp;
1432 
1433       Rtyp       : Entity_Id;
1434       Param      : Node_Id;
1435       Param_Spec : Node_Id;
1436       Param_Type : Entity_Id;
1437 
1438    --  Start of processing for Validate_RACW_Primitive
1439 
1440    begin
1441       --  Check return type
1442 
1443       if Ekind (Subp) = E_Function then
1444          Rtyp := Etype (Subp);
1445 
1446          --  AI05-0101 (Binding Interpretation): The result type of a remote
1447          --  function must either support external streaming or be a
1448          --  controlling access result type.
1449 
1450          if Has_Controlling_Result (Subp) then
1451             null;
1452 
1453          elsif Ekind (Rtyp) = E_Anonymous_Access_Type then
1454             Illegal_Remote_Subp ("anonymous access result", Rtyp);
1455 
1456          elsif Is_Limited_Type (Rtyp) then
1457             if No (TSS (Rtyp, TSS_Stream_Read))
1458                  or else
1459                No (TSS (Rtyp, TSS_Stream_Write))
1460             then
1461                Illegal_Remote_Subp
1462                  ("limited return type must have Read and Write attributes",
1463                      Parent (Subp));
1464                Explain_Limited_Type (Rtyp, Parent (Subp));
1465             end if;
1466 
1467          --  Check that the return type supports external streaming
1468 
1469          elsif No_External_Streaming (Rtyp)
1470            and then not Error_Posted (Rtyp)
1471          then
1472             Illegal_Remote_Subp ("return type containing non-remote access "
1473               & "must have Read and Write attributes",
1474               Parent (Subp));
1475          end if;
1476       end if;
1477 
1478       Param := First_Formal (Subp);
1479       while Present (Param) loop
1480 
1481          --  Now find out if this parameter is a controlling parameter
1482 
1483          Param_Spec := Parent (Param);
1484          Param_Type := Etype (Param);
1485 
1486          if Is_Controlling_Formal (Param) then
1487 
1488             --  It is a controlling parameter, so specific checks below do not
1489             --  apply.
1490 
1491             null;
1492 
1493          elsif Ekind_In (Param_Type, E_Anonymous_Access_Type,
1494                                      E_Anonymous_Access_Subprogram_Type)
1495          then
1496             --  From RM E.2.2(14), no anonymous access parameter other than
1497             --  controlling ones may be used (because an anonymous access
1498             --  type never supports external streaming).
1499 
1500             Illegal_Remote_Subp
1501               ("non-controlling access parameter", Param_Spec);
1502 
1503          elsif No_External_Streaming (Param_Type)
1504             and then not Error_Posted (Param_Type)
1505          then
1506             Illegal_Remote_Subp ("formal parameter in remote subprogram must "
1507               & "support external streaming", Param_Spec);
1508          end if;
1509 
1510          --  Check next parameter in this subprogram
1511 
1512          Next_Formal (Param);
1513       end loop;
1514    end Validate_RACW_Primitive;
1515 
1516    ------------------------------
1517    -- Validate_RACW_Primitives --
1518    ------------------------------
1519 
1520    procedure Validate_RACW_Primitives (T : Entity_Id) is
1521       Desig_Type             : Entity_Id;
1522       Primitive_Subprograms  : Elist_Id;
1523       Subprogram_Elmt        : Elmt_Id;
1524       Subprogram             : Entity_Id;
1525 
1526    begin
1527       Desig_Type := Etype (Designated_Type (T));
1528 
1529       --  No action needed for concurrent types
1530 
1531       if Is_Concurrent_Type (Desig_Type) then
1532          return;
1533       end if;
1534 
1535       Primitive_Subprograms := Primitive_Operations (Desig_Type);
1536 
1537       Subprogram_Elmt := First_Elmt (Primitive_Subprograms);
1538       while Subprogram_Elmt /= No_Elmt loop
1539          Subprogram := Node (Subprogram_Elmt);
1540 
1541          if Is_Predefined_Dispatching_Operation (Subprogram)
1542            or else Is_Hidden (Subprogram)
1543          then
1544             goto Next_Subprogram;
1545          end if;
1546 
1547          Validate_RACW_Primitive (Subp => Subprogram, RACW => T);
1548 
1549       <<Next_Subprogram>>
1550          Next_Elmt (Subprogram_Elmt);
1551       end loop;
1552    end Validate_RACW_Primitives;
1553 
1554    -------------------------------
1555    -- Validate_RCI_Declarations --
1556    -------------------------------
1557 
1558    procedure Validate_RCI_Declarations (P : Entity_Id) is
1559       E : Entity_Id;
1560 
1561    begin
1562       E := First_Entity (P);
1563       while Present (E) loop
1564          if Comes_From_Source (E) then
1565             if Is_Limited_Type (E) then
1566                Error_Msg_N
1567                  ("limited type not allowed in rci unit", Parent (E));
1568                Explain_Limited_Type (E, Parent (E));
1569 
1570             elsif Ekind_In (E, E_Generic_Function,
1571                                E_Generic_Package,
1572                                E_Generic_Procedure)
1573             then
1574                Error_Msg_N ("generic declaration not allowed in rci unit",
1575                  Parent (E));
1576 
1577             elsif (Ekind (E) = E_Function or else Ekind (E) = E_Procedure)
1578               and then Has_Pragma_Inline (E)
1579             then
1580                Error_Msg_N
1581                  ("inlined subprogram not allowed in rci unit", Parent (E));
1582 
1583             --  Inner packages that are renamings need not be checked. Generic
1584             --  RCI packages are subject to the checks, but entities that come
1585             --  from formal packages are not part of the visible declarations
1586             --  of the package and are not checked.
1587 
1588             elsif Ekind (E) = E_Package then
1589                if Present (Renamed_Entity (E)) then
1590                   null;
1591 
1592                elsif Ekind (P) /= E_Generic_Package
1593                  or else List_Containing (Unit_Declaration_Node (E)) /=
1594                            Generic_Formal_Declarations
1595                              (Unit_Declaration_Node (P))
1596                then
1597                   Validate_RCI_Declarations (E);
1598                end if;
1599             end if;
1600          end if;
1601 
1602          Next_Entity (E);
1603       end loop;
1604    end Validate_RCI_Declarations;
1605 
1606    -----------------------------------------
1607    -- Validate_RCI_Subprogram_Declaration --
1608    -----------------------------------------
1609 
1610    procedure Validate_RCI_Subprogram_Declaration (N : Node_Id) is
1611       K               : constant Node_Kind := Nkind (N);
1612       Profile         : List_Id;
1613       Id              : constant Entity_Id := Defining_Entity (N);
1614       Param_Spec      : Node_Id;
1615       Param_Type      : Entity_Id;
1616       Error_Node      : Node_Id := N;
1617 
1618    begin
1619       --  This procedure enforces rules on subprogram and access to subprogram
1620       --  declarations in RCI units. These rules do not apply to expander
1621       --  generated routines, which are not remote subprograms. It is called:
1622 
1623       --    1. from Analyze_Subprogram_Declaration.
1624       --    2. from Validate_Object_Declaration (access to subprogram).
1625 
1626       if not (Comes_From_Source (N)
1627                 and then In_RCI_Declaration
1628                 and then not In_Private_Part (Scope (Id)))
1629       then
1630          return;
1631       end if;
1632 
1633       if K = N_Subprogram_Declaration then
1634          Profile := Parameter_Specifications (Specification (N));
1635 
1636       else
1637          pragma Assert (K = N_Object_Declaration);
1638 
1639          --  The above assertion is dubious, the visible declarations of an
1640          --  RCI unit never contain an object declaration, this should be an
1641          --  ACCESS-to-object declaration???
1642 
1643          if Nkind (Id) = N_Defining_Identifier
1644            and then Nkind (Parent (Etype (Id))) = N_Full_Type_Declaration
1645            and then Ekind (Etype (Id)) = E_Access_Subprogram_Type
1646          then
1647             Profile :=
1648               Parameter_Specifications (Type_Definition (Parent (Etype (Id))));
1649          else
1650             return;
1651          end if;
1652       end if;
1653 
1654       --  Iterate through the parameter specification list, checking that
1655       --  no access parameter and no limited type parameter in the list.
1656       --  RM E.2.3(14).
1657 
1658       if Present (Profile) then
1659          Param_Spec := First (Profile);
1660          while Present (Param_Spec) loop
1661             Param_Type := Etype (Defining_Identifier (Param_Spec));
1662 
1663             if Ekind (Param_Type) = E_Anonymous_Access_Type then
1664                if K = N_Subprogram_Declaration then
1665                   Error_Node := Param_Spec;
1666                end if;
1667 
1668                --  Report error only if declaration is in source program
1669 
1670                if Comes_From_Source (Id) then
1671                   Error_Msg_N
1672                     ("subprogram in 'R'C'I unit cannot have access parameter",
1673                      Error_Node);
1674                end if;
1675 
1676             --  For a limited private type parameter, we check only the private
1677             --  declaration and ignore full type declaration, unless this is
1678             --  the only declaration for the type, e.g., as a limited record.
1679 
1680             elsif No_External_Streaming (Param_Type) then
1681                if K = N_Subprogram_Declaration then
1682                   Error_Node := Param_Spec;
1683                end if;
1684 
1685                Error_Msg_NE
1686                  ("formal of remote subprogram& "
1687                   & "must support external streaming",
1688                   Error_Node, Id);
1689                if Is_Limited_Type (Param_Type) then
1690                   Explain_Limited_Type (Param_Type, Error_Node);
1691                end if;
1692             end if;
1693 
1694             Next (Param_Spec);
1695          end loop;
1696       end if;
1697 
1698       if Ekind (Id) = E_Function
1699         and then Ekind (Etype (Id)) = E_Anonymous_Access_Type
1700         and then Comes_From_Source (Id)
1701       then
1702          Error_Msg_N
1703            ("function in 'R'C'I unit cannot have access result",
1704              Error_Node);
1705       end if;
1706    end Validate_RCI_Subprogram_Declaration;
1707 
1708    ----------------------------------------------------
1709    -- Validate_Remote_Access_Object_Type_Declaration --
1710    ----------------------------------------------------
1711 
1712    procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is
1713       Direct_Designated_Type : Entity_Id;
1714       Desig_Type             : Entity_Id;
1715 
1716    begin
1717       --  We are called from Analyze_Full_Type_Declaration, and the Nkind of
1718       --  the given node is N_Access_To_Object_Definition.
1719 
1720       if not Comes_From_Source (T)
1721         or else (not In_RCI_Declaration and then not In_RT_Declaration)
1722       then
1723          return;
1724       end if;
1725 
1726       --  An access definition in the private part of a package is not a
1727       --  remote access type. Restrictions related to external streaming
1728       --  support for non-remote access types are enforced elsewhere. Note
1729       --  that In_Private_Part is never set on type entities: check flag
1730       --  on enclosing scope.
1731 
1732       if In_Private_Part (Scope (T)) then
1733          return;
1734       end if;
1735 
1736       --  Check RCI or RT unit type declaration. It may not contain the
1737       --  declaration of an access-to-object type unless it is a general access
1738       --  type that designates a class-wide limited private type or subtype.
1739       --  There are also constraints on the primitive subprograms of the
1740       --  class-wide type (RM E.2.2(14), see Validate_RACW_Primitives).
1741 
1742       if Ekind (T) /= E_General_Access_Type
1743         or else not Is_Class_Wide_Type (Designated_Type (T))
1744       then
1745          if In_RCI_Declaration then
1746             Error_Msg_N
1747               ("error in access type in Remote_Call_Interface unit", T);
1748          else
1749             Error_Msg_N
1750               ("error in access type in Remote_Types unit", T);
1751          end if;
1752 
1753          Error_Msg_N ("\must be general access to class-wide type", T);
1754          return;
1755       end if;
1756 
1757       Direct_Designated_Type := Designated_Type (T);
1758       Desig_Type := Etype (Direct_Designated_Type);
1759 
1760       --  Why is this check not in Validate_Remote_Access_To_Class_Wide_Type???
1761 
1762       if not Is_Valid_Remote_Object_Type (Desig_Type) then
1763          Error_Msg_N
1764            ("error in designated type of remote access to class-wide type", T);
1765          Error_Msg_N
1766            ("\must be tagged limited private or private extension", T);
1767          return;
1768       end if;
1769    end Validate_Remote_Access_Object_Type_Declaration;
1770 
1771    -----------------------------------------------
1772    -- Validate_Remote_Access_To_Class_Wide_Type --
1773    -----------------------------------------------
1774 
1775    procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id) is
1776       K  : constant Node_Kind := Nkind (N);
1777       PK : constant Node_Kind := Nkind (Parent (N));
1778       E  : Entity_Id;
1779 
1780    begin
1781       --  This subprogram enforces the checks in (RM E.2.2(8)) for certain uses
1782       --  of class-wide limited private types.
1783 
1784       --    Storage_Pool and Storage_Size are not defined for such types
1785       --
1786       --    The expected type of allocator must not be such a type.
1787 
1788       --    The actual parameter of generic instantiation must not be such a
1789       --    type if the formal parameter is of an access type.
1790 
1791       --  On entry, there are several cases:
1792 
1793       --    1. called from sem_attr Analyze_Attribute where attribute name is
1794       --       either Storage_Pool or Storage_Size.
1795 
1796       --    2. called from exp_ch4 Expand_N_Allocator
1797 
1798       --    3. called from sem_ch4 Analyze_Explicit_Dereference
1799 
1800       --    4. called from sem_res Resolve_Actuals
1801 
1802       if K = N_Attribute_Reference then
1803          E := Etype (Prefix (N));
1804 
1805          if Is_Remote_Access_To_Class_Wide_Type (E) then
1806             Error_Msg_N ("incorrect attribute of remote operand", N);
1807             return;
1808          end if;
1809 
1810       elsif K = N_Allocator then
1811          E := Etype (N);
1812 
1813          if Is_Remote_Access_To_Class_Wide_Type (E) then
1814             Error_Msg_N ("incorrect expected remote type of allocator", N);
1815             return;
1816          end if;
1817 
1818       --  This subprogram also enforces the checks in E.2.2(13). A value of
1819       --  such type must not be dereferenced unless as controlling operand of
1820       --  a dispatching call. Explicit dereferences not coming from source are
1821       --  exempted from this checking because the expander produces them in
1822       --  some cases (such as for tag checks on dispatching calls with multiple
1823       --  controlling operands). However we do check in the case of an implicit
1824       --  dereference that is expanded to an explicit dereference (hence the
1825       --  test of whether Original_Node (N) comes from source).
1826 
1827       elsif K = N_Explicit_Dereference
1828         and then Comes_From_Source (Original_Node (N))
1829       then
1830          E := Etype (Prefix (N));
1831 
1832          --  If the class-wide type is not a remote one, the restrictions
1833          --  do not apply.
1834 
1835          if not Is_Remote_Access_To_Class_Wide_Type (E) then
1836             return;
1837          end if;
1838 
1839          --  If we have a true dereference that comes from source and that
1840          --  is a controlling argument for a dispatching call, accept it.
1841 
1842          if Is_Actual_Parameter (N) and then Is_Controlling_Actual (N) then
1843             return;
1844          end if;
1845 
1846          --  If we are just within a procedure or function call and the
1847          --  dereference has not been analyzed, return because this procedure
1848          --  will be called again from sem_res Resolve_Actuals. The same can
1849          --  apply in the case of dereference that is the prefix of a selected
1850          --  component, which can be a call given in prefixed form.
1851 
1852          if (Is_Actual_Parameter (N) or else PK = N_Selected_Component)
1853            and then not Analyzed (N)
1854          then
1855             return;
1856          end if;
1857 
1858          --  We must allow expanded code to generate a reference to the tag of
1859          --  the designated object (may be either the actual tag, or the stub
1860          --  tag in the case of a remote object).
1861 
1862          if PK = N_Selected_Component
1863            and then Is_Tag (Entity (Selector_Name (Parent (N))))
1864          then
1865             return;
1866          end if;
1867 
1868          Error_Msg_N
1869            ("invalid dereference of a remote access-to-class-wide value", N);
1870       end if;
1871    end Validate_Remote_Access_To_Class_Wide_Type;
1872 
1873    ------------------------------------------
1874    -- Validate_Remote_Type_Type_Conversion --
1875    ------------------------------------------
1876 
1877    procedure Validate_Remote_Type_Type_Conversion (N : Node_Id) is
1878       S : constant Entity_Id := Etype (N);
1879       E : constant Entity_Id := Etype (Expression (N));
1880 
1881    begin
1882       --  This test is required in the case where a conversion appears inside a
1883       --  normal package, it does not necessarily have to be inside an RCI,
1884       --  Remote_Types unit (RM E.2.2(9,12)).
1885 
1886       if Is_Remote_Access_To_Subprogram_Type (E)
1887         and then not Is_Remote_Access_To_Subprogram_Type (S)
1888       then
1889          Error_Msg_N
1890            ("incorrect conversion of remote operand to local type", N);
1891          return;
1892 
1893       elsif not Is_Remote_Access_To_Subprogram_Type (E)
1894         and then Is_Remote_Access_To_Subprogram_Type (S)
1895       then
1896          Error_Msg_N
1897            ("incorrect conversion of local operand to remote type", N);
1898          return;
1899 
1900       elsif Is_Remote_Access_To_Class_Wide_Type (E)
1901         and then not Is_Remote_Access_To_Class_Wide_Type (S)
1902       then
1903          Error_Msg_N
1904            ("incorrect conversion of remote operand to local type", N);
1905          return;
1906       end if;
1907 
1908       --  If a local access type is converted into a RACW type, then the
1909       --  current unit has a pointer that may now be exported to another
1910       --  partition.
1911 
1912       if Is_Remote_Access_To_Class_Wide_Type (S)
1913         and then not Is_Remote_Access_To_Class_Wide_Type (E)
1914       then
1915          Set_Has_RACW (Current_Sem_Unit);
1916       end if;
1917    end Validate_Remote_Type_Type_Conversion;
1918 
1919    -------------------------------
1920    -- Validate_RT_RAT_Component --
1921    -------------------------------
1922 
1923    procedure Validate_RT_RAT_Component (N : Node_Id) is
1924       Spec           : constant Node_Id   := Specification (N);
1925       Name_U         : constant Entity_Id := Defining_Entity (Spec);
1926       Typ            : Entity_Id;
1927       U_Typ          : Entity_Id;
1928       First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U);
1929 
1930       function Stream_Attributes_Available (Typ : Entity_Id) return Boolean;
1931       --  True if any stream attribute is available for Typ
1932 
1933       ---------------------------------
1934       -- Stream_Attributes_Available --
1935       ---------------------------------
1936 
1937       function Stream_Attributes_Available (Typ : Entity_Id) return Boolean
1938       is
1939       begin
1940          return Stream_Attribute_Available (Typ, TSS_Stream_Read)
1941                   or else
1942                 Stream_Attribute_Available (Typ, TSS_Stream_Write)
1943                   or else
1944                 Stream_Attribute_Available (Typ, TSS_Stream_Input)
1945                   or else
1946                 Stream_Attribute_Available (Typ, TSS_Stream_Output);
1947       end Stream_Attributes_Available;
1948 
1949    --  Start of processing for Validate_RT_RAT_Component
1950 
1951    begin
1952       if not Is_Remote_Types (Name_U) then
1953          return;
1954       end if;
1955 
1956       Typ := First_Entity (Name_U);
1957       while Present (Typ) and then Typ /= First_Priv_Ent loop
1958          U_Typ := Underlying_Type (Base_Type (Typ));
1959 
1960          if No (U_Typ) then
1961             U_Typ := Typ;
1962          end if;
1963 
1964          if Comes_From_Source (Typ) and then Is_Type (Typ) then
1965 
1966             --  Check that the type can be meaningfully transmitted to another
1967             --  partition (E.2.2(8)).
1968 
1969             if (Ada_Version < Ada_2005 and then Has_Non_Remote_Access (U_Typ))
1970                  or else (Stream_Attributes_Available (Typ)
1971                            and then No_External_Streaming (U_Typ))
1972             then
1973                if Is_Non_Remote_Access_Type (Typ) then
1974                   Error_Msg_N ("error in non-remote access type", U_Typ);
1975                else
1976                   Error_Msg_N
1977                     ("error in record type containing a component of a " &
1978                      "non-remote access type", U_Typ);
1979                end if;
1980 
1981                if Ada_Version >= Ada_2005 then
1982                   Error_Msg_N
1983                     ("\must have visible Read and Write attribute " &
1984                      "definition clauses (RM E.2.2(8))", U_Typ);
1985                else
1986                   Error_Msg_N
1987                     ("\must have Read and Write attribute " &
1988                      "definition clauses (RM E.2.2(8))", U_Typ);
1989                end if;
1990             end if;
1991          end if;
1992 
1993          Next_Entity (Typ);
1994       end loop;
1995    end Validate_RT_RAT_Component;
1996 
1997    -----------------------------------------
1998    -- Validate_SP_Access_Object_Type_Decl --
1999    -----------------------------------------
2000 
2001    procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id) is
2002       Direct_Designated_Type : Entity_Id;
2003 
2004       function Has_Entry_Declarations (E : Entity_Id) return Boolean;
2005       --  Return true if the protected type designated by T has entry
2006       --  declarations.
2007 
2008       ----------------------------
2009       -- Has_Entry_Declarations --
2010       ----------------------------
2011 
2012       function Has_Entry_Declarations (E : Entity_Id) return Boolean is
2013          Ety : Entity_Id;
2014 
2015       begin
2016          if Nkind (Parent (E)) = N_Protected_Type_Declaration then
2017             Ety := First_Entity (E);
2018             while Present (Ety) loop
2019                if Ekind (Ety) = E_Entry then
2020                   return True;
2021                end if;
2022 
2023                Next_Entity (Ety);
2024             end loop;
2025          end if;
2026 
2027          return False;
2028       end Has_Entry_Declarations;
2029 
2030    --  Start of processing for Validate_SP_Access_Object_Type_Decl
2031 
2032    begin
2033       --  We are called from Sem_Ch3.Analyze_Full_Type_Declaration, and the
2034       --  Nkind of the given entity is N_Access_To_Object_Definition.
2035 
2036       if not Comes_From_Source (T)
2037         or else not In_Shared_Passive_Unit
2038         or else In_Subprogram_Task_Protected_Unit
2039       then
2040          return;
2041       end if;
2042 
2043       --  Check Shared Passive unit. It should not contain the declaration
2044       --  of an access-to-object type whose designated type is a class-wide
2045       --  type, task type or protected type with entry (RM E.2.1(7)).
2046 
2047       Direct_Designated_Type := Designated_Type (T);
2048 
2049       if Ekind (Direct_Designated_Type) = E_Class_Wide_Type then
2050          Error_Msg_N
2051            ("invalid access-to-class-wide type in shared passive unit", T);
2052          return;
2053 
2054       elsif Ekind (Direct_Designated_Type) in Task_Kind then
2055          Error_Msg_N
2056            ("invalid access-to-task type in shared passive unit", T);
2057          return;
2058 
2059       elsif Ekind (Direct_Designated_Type) in Protected_Kind
2060         and then Has_Entry_Declarations (Direct_Designated_Type)
2061       then
2062          Error_Msg_N
2063            ("invalid access-to-protected type in shared passive unit", T);
2064          return;
2065       end if;
2066    end Validate_SP_Access_Object_Type_Decl;
2067 
2068    ---------------------------------
2069    -- Validate_Static_Object_Name --
2070    ---------------------------------
2071 
2072    procedure Validate_Static_Object_Name (N : Node_Id) is
2073       E   : Entity_Id;
2074       Val : Node_Id;
2075 
2076       function Is_Primary (N : Node_Id) return Boolean;
2077       --  Determine whether node is syntactically a primary in an expression
2078       --  This function should probably be somewhere else ???
2079       --
2080       --  Also it does not do what it says, e.g if N is a binary operator
2081       --  whose parent is a binary operator, Is_Primary returns True ???
2082 
2083       ----------------
2084       -- Is_Primary --
2085       ----------------
2086 
2087       function Is_Primary (N : Node_Id) return Boolean is
2088          K : constant Node_Kind := Nkind (Parent (N));
2089 
2090       begin
2091          case K is
2092             when N_Op | N_Membership_Test =>
2093                return True;
2094 
2095             when N_Aggregate
2096                | N_Component_Association
2097                | N_Index_Or_Discriminant_Constraint =>
2098                return True;
2099 
2100             when N_Attribute_Reference =>
2101                return Attribute_Name (Parent (N)) /= Name_Address
2102                  and then Attribute_Name (Parent (N)) /= Name_Access
2103                  and then Attribute_Name (Parent (N)) /= Name_Unchecked_Access
2104                  and then
2105                    Attribute_Name (Parent (N)) /= Name_Unrestricted_Access;
2106 
2107             when N_Indexed_Component =>
2108                return (N /= Prefix (Parent (N))
2109                  or else Is_Primary (Parent (N)));
2110 
2111             when N_Qualified_Expression | N_Type_Conversion =>
2112                return Is_Primary (Parent (N));
2113 
2114             when N_Assignment_Statement | N_Object_Declaration =>
2115                return (N = Expression (Parent (N)));
2116 
2117             when N_Selected_Component =>
2118                return Is_Primary (Parent (N));
2119 
2120             when others =>
2121                return False;
2122          end case;
2123       end Is_Primary;
2124 
2125    --  Start of processing for Validate_Static_Object_Name
2126 
2127    begin
2128       if not In_Preelaborated_Unit
2129         or else not Comes_From_Source (N)
2130         or else In_Subprogram_Or_Concurrent_Unit
2131         or else Ekind (Current_Scope) = E_Block
2132       then
2133          return;
2134 
2135       --  Filter out cases where primary is default in a component declaration,
2136       --  discriminant specification, or actual in a record type initialization
2137       --  call.
2138 
2139       --  Initialization call of internal types
2140 
2141       elsif Nkind (Parent (N)) = N_Procedure_Call_Statement then
2142 
2143          if Present (Parent (Parent (N)))
2144            and then Nkind (Parent (Parent (N))) = N_Freeze_Entity
2145          then
2146             return;
2147          end if;
2148 
2149          if Nkind (Name (Parent (N))) = N_Identifier
2150            and then not Comes_From_Source (Entity (Name (Parent (N))))
2151          then
2152             return;
2153          end if;
2154       end if;
2155 
2156       --  Error if the name is a primary in an expression. The parent must not
2157       --  be an operator, or a selected component or an indexed component that
2158       --  is itself a primary. Entities that are actuals do not need to be
2159       --  checked, because the call itself will be diagnosed.
2160 
2161       if Is_Primary (N)
2162         and then (not Inside_A_Generic
2163                    or else Present (Enclosing_Generic_Body (N)))
2164       then
2165          if Ekind (Entity (N)) = E_Variable
2166            or else Ekind (Entity (N)) in Formal_Object_Kind
2167          then
2168             Flag_Non_Static_Expr
2169               ("non-static object name in preelaborated unit", N);
2170 
2171          --  Give an error for a reference to a nonstatic constant, unless the
2172          --  constant is in another GNAT library unit that is preelaborable.
2173 
2174          elsif Ekind (Entity (N)) = E_Constant
2175            and then not Is_Static_Expression (N)
2176          then
2177             E   := Entity (N);
2178             Val := Constant_Value (E);
2179 
2180             if Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)))
2181               and then
2182                 Enclosing_Comp_Unit_Node (N) /= Enclosing_Comp_Unit_Node (E)
2183               and then (Is_Preelaborated (Scope (E))
2184                          or else Is_Pure (Scope (E))
2185                          or else (Present (Renamed_Object (E))
2186                                    and then Is_Entity_Name (Renamed_Object (E))
2187                                    and then
2188                                      (Is_Preelaborated
2189                                         (Scope (Renamed_Object (E)))
2190                                        or else
2191                                          Is_Pure
2192                                            (Scope (Renamed_Object (E))))))
2193             then
2194                null;
2195 
2196             --  If the value of the constant is a local variable that renames
2197             --  an aggregate, this is in itself legal. The aggregate may be
2198             --  expanded into a loop, but this does not affect preelaborability
2199             --  in itself. If some aggregate components are non-static, that is
2200             --  to say if they involve non static primaries, they will be
2201             --  flagged when analyzed.
2202 
2203             elsif Present (Val)
2204               and then Is_Entity_Name (Val)
2205               and then Is_Array_Type (Etype (Val))
2206               and then not Comes_From_Source (Val)
2207               and then Nkind (Original_Node (Val)) = N_Aggregate
2208             then
2209                null;
2210 
2211             --  This is the error case
2212 
2213             else
2214                --  In GNAT mode or Relaxed RM Semantic mode, this is just a
2215                --  warning, to allow it to be judiciously turned off.
2216                --  Otherwise it is a real error.
2217 
2218                if GNAT_Mode or Relaxed_RM_Semantics then
2219                   Error_Msg_N
2220                     ("??non-static constant in preelaborated unit", N);
2221                else
2222                   Flag_Non_Static_Expr
2223                     ("non-static constant in preelaborated unit", N);
2224                end if;
2225             end if;
2226          end if;
2227       end if;
2228    end Validate_Static_Object_Name;
2229 
2230 end Sem_Cat;