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