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