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