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