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