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