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