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