1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 9 -- 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 Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Contracts; use Contracts; 30with Debug; use Debug; 31with Einfo; use Einfo; 32with Errout; use Errout; 33with Exp_Ch9; use Exp_Ch9; 34with Elists; use Elists; 35with Freeze; use Freeze; 36with Layout; use Layout; 37with Lib; use Lib; 38with Lib.Xref; use Lib.Xref; 39with Namet; use Namet; 40with Nlists; use Nlists; 41with Nmake; use Nmake; 42with Opt; use Opt; 43with Restrict; use Restrict; 44with Rident; use Rident; 45with Rtsfind; use Rtsfind; 46with Sem; use Sem; 47with Sem_Aux; use Sem_Aux; 48with Sem_Ch3; use Sem_Ch3; 49with Sem_Ch5; use Sem_Ch5; 50with Sem_Ch6; use Sem_Ch6; 51with Sem_Ch8; use Sem_Ch8; 52with Sem_Ch13; use Sem_Ch13; 53with Sem_Elab; use Sem_Elab; 54with Sem_Eval; use Sem_Eval; 55with Sem_Prag; use Sem_Prag; 56with Sem_Res; use Sem_Res; 57with Sem_Type; use Sem_Type; 58with Sem_Util; use Sem_Util; 59with Sem_Warn; use Sem_Warn; 60with Snames; use Snames; 61with Stand; use Stand; 62with Sinfo; use Sinfo; 63with Style; 64with Tbuild; use Tbuild; 65with Uintp; use Uintp; 66 67package body Sem_Ch9 is 68 69 ----------------------- 70 -- Local Subprograms -- 71 ----------------------- 72 73 function Allows_Lock_Free_Implementation 74 (N : Node_Id; 75 Lock_Free_Given : Boolean := False) return Boolean; 76 -- This routine returns True iff N satisfies the following list of lock- 77 -- free restrictions for protected type declaration and protected body: 78 -- 79 -- 1) Protected type declaration 80 -- May not contain entries 81 -- Protected subprogram declarations may not have non-elementary 82 -- parameters. 83 -- 84 -- 2) Protected Body 85 -- Each protected subprogram body within N must satisfy: 86 -- May reference only one protected component 87 -- May not reference non-constant entities outside the protected 88 -- subprogram scope. 89 -- May not contain address representation items, allocators and 90 -- quantified expressions. 91 -- May not contain delay, goto, loop and procedure call 92 -- statements. 93 -- May not contain exported and imported entities 94 -- May not dereference access values 95 -- Function calls and attribute references must be static 96 -- 97 -- If Lock_Free_Given is True, an error message is issued when False is 98 -- returned. 99 100 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions); 101 -- Given either a protected definition or a task definition in D, check 102 -- the corresponding restriction parameter identifier R, and if it is set, 103 -- count the entries (checking the static requirement), and compare with 104 -- the given maximum. 105 106 procedure Check_Interfaces (N : Node_Id; T : Entity_Id); 107 -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node. 108 -- Complete decoration of T and check legality of the covered interfaces. 109 110 procedure Check_Triggering_Statement 111 (Trigger : Node_Id; 112 Error_Node : Node_Id; 113 Is_Dispatching : out Boolean); 114 -- Examine the triggering statement of a select statement, conditional or 115 -- timed entry call. If Trigger is a dispatching call, return its status 116 -- in Is_Dispatching and check whether the primitive belongs to a limited 117 -- interface. If it does not, emit an error at Error_Node. 118 119 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id; 120 -- Find entity in corresponding task or protected declaration. Use full 121 -- view if first declaration was for an incomplete type. 122 123 ------------------------------------- 124 -- Allows_Lock_Free_Implementation -- 125 ------------------------------------- 126 127 function Allows_Lock_Free_Implementation 128 (N : Node_Id; 129 Lock_Free_Given : Boolean := False) return Boolean 130 is 131 Errors_Count : Nat := 0; 132 -- Errors_Count is a count of errors detected by the compiler so far 133 -- when Lock_Free_Given is True. 134 135 begin 136 pragma Assert (Nkind_In (N, N_Protected_Type_Declaration, 137 N_Protected_Body)); 138 139 -- The lock-free implementation is currently enabled through a debug 140 -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the 141 -- lock-free implementation. In that case, the debug flag is not needed. 142 143 if not Lock_Free_Given and then not Debug_Flag_9 then 144 return False; 145 end if; 146 147 -- Get the number of errors detected by the compiler so far 148 149 if Lock_Free_Given then 150 Errors_Count := Serious_Errors_Detected; 151 end if; 152 153 -- Protected type declaration case 154 155 if Nkind (N) = N_Protected_Type_Declaration then 156 declare 157 Pdef : constant Node_Id := Protected_Definition (N); 158 Priv_Decls : constant List_Id := Private_Declarations (Pdef); 159 Vis_Decls : constant List_Id := Visible_Declarations (Pdef); 160 Decl : Node_Id; 161 162 begin 163 -- Examine the visible and the private declarations 164 165 Decl := First (Vis_Decls); 166 while Present (Decl) loop 167 168 -- Entries and entry families are not allowed by the lock-free 169 -- restrictions. 170 171 if Nkind (Decl) = N_Entry_Declaration then 172 if Lock_Free_Given then 173 Error_Msg_N 174 ("entry not allowed when Lock_Free given", Decl); 175 else 176 return False; 177 end if; 178 179 -- Non-elementary parameters in protected procedure are not 180 -- allowed by the lock-free restrictions. 181 182 elsif Nkind (Decl) = N_Subprogram_Declaration 183 and then 184 Nkind (Specification (Decl)) = N_Procedure_Specification 185 and then 186 Present (Parameter_Specifications (Specification (Decl))) 187 then 188 declare 189 Par_Specs : constant List_Id := 190 Parameter_Specifications 191 (Specification (Decl)); 192 193 Par : Node_Id; 194 195 begin 196 Par := First (Par_Specs); 197 while Present (Par) loop 198 if not Is_Elementary_Type 199 (Etype (Defining_Identifier (Par))) 200 then 201 if Lock_Free_Given then 202 Error_Msg_NE 203 ("non-elementary parameter& not allowed " 204 & "when Lock_Free given", 205 Par, Defining_Identifier (Par)); 206 else 207 return False; 208 end if; 209 end if; 210 211 Next (Par); 212 end loop; 213 end; 214 end if; 215 216 -- Examine private declarations after visible declarations 217 218 if No (Next (Decl)) 219 and then List_Containing (Decl) = Vis_Decls 220 then 221 Decl := First (Priv_Decls); 222 else 223 Next (Decl); 224 end if; 225 end loop; 226 end; 227 228 -- Protected body case 229 230 else 231 Protected_Body_Case : declare 232 Decls : constant List_Id := Declarations (N); 233 Pid : constant Entity_Id := Corresponding_Spec (N); 234 Prot_Typ_Decl : constant Node_Id := Parent (Pid); 235 Prot_Def : constant Node_Id := 236 Protected_Definition (Prot_Typ_Decl); 237 Priv_Decls : constant List_Id := 238 Private_Declarations (Prot_Def); 239 Decl : Node_Id; 240 241 function Satisfies_Lock_Free_Requirements 242 (Sub_Body : Node_Id) return Boolean; 243 -- Return True if protected subprogram body Sub_Body satisfies all 244 -- requirements of a lock-free implementation. 245 246 -------------------------------------- 247 -- Satisfies_Lock_Free_Requirements -- 248 -------------------------------------- 249 250 function Satisfies_Lock_Free_Requirements 251 (Sub_Body : Node_Id) return Boolean 252 is 253 Is_Procedure : constant Boolean := 254 Ekind (Corresponding_Spec (Sub_Body)) = 255 E_Procedure; 256 -- Indicates if Sub_Body is a procedure body 257 258 Comp : Entity_Id := Empty; 259 -- Track the current component which the body references 260 261 Errors_Count : Nat := 0; 262 -- Errors_Count is a count of errors detected by the compiler 263 -- so far when Lock_Free_Given is True. 264 265 function Check_Node (N : Node_Id) return Traverse_Result; 266 -- Check that node N meets the lock free restrictions 267 268 ---------------- 269 -- Check_Node -- 270 ---------------- 271 272 function Check_Node (N : Node_Id) return Traverse_Result is 273 Kind : constant Node_Kind := Nkind (N); 274 275 -- The following function belongs in sem_eval ??? 276 277 function Is_Static_Function (Attr : Node_Id) return Boolean; 278 -- Given an attribute reference node Attr, return True if 279 -- Attr denotes a static function according to the rules in 280 -- (RM 4.9 (22)). 281 282 ------------------------ 283 -- Is_Static_Function -- 284 ------------------------ 285 286 function Is_Static_Function 287 (Attr : Node_Id) return Boolean 288 is 289 Para : Node_Id; 290 291 begin 292 pragma Assert (Nkind (Attr) = N_Attribute_Reference); 293 294 case Attribute_Name (Attr) is 295 when Name_Max 296 | Name_Min 297 | Name_Pred 298 | Name_Succ 299 | Name_Value 300 | Name_Wide_Value 301 | Name_Wide_Wide_Value 302 => 303 -- A language-defined attribute denotes a static 304 -- function if the prefix denotes a static scalar 305 -- subtype, and if the parameter and result types 306 -- are scalar (RM 4.9 (22)). 307 308 if Is_Scalar_Type (Etype (Attr)) 309 and then Is_Scalar_Type (Etype (Prefix (Attr))) 310 and then 311 Is_OK_Static_Subtype (Etype (Prefix (Attr))) 312 then 313 Para := First (Expressions (Attr)); 314 315 while Present (Para) loop 316 if not Is_Scalar_Type (Etype (Para)) then 317 return False; 318 end if; 319 320 Next (Para); 321 end loop; 322 323 return True; 324 325 else 326 return False; 327 end if; 328 329 when others => 330 return False; 331 end case; 332 end Is_Static_Function; 333 334 -- Start of processing for Check_Node 335 336 begin 337 if Is_Procedure then 338 -- Allocators restricted 339 340 if Kind = N_Allocator then 341 if Lock_Free_Given then 342 Error_Msg_N ("allocator not allowed", N); 343 return Skip; 344 end if; 345 346 return Abandon; 347 348 -- Aspects Address, Export and Import restricted 349 350 elsif Kind = N_Aspect_Specification then 351 declare 352 Asp_Name : constant Name_Id := 353 Chars (Identifier (N)); 354 Asp_Id : constant Aspect_Id := 355 Get_Aspect_Id (Asp_Name); 356 357 begin 358 if Asp_Id = Aspect_Address or else 359 Asp_Id = Aspect_Export or else 360 Asp_Id = Aspect_Import 361 then 362 Error_Msg_Name_1 := Asp_Name; 363 364 if Lock_Free_Given then 365 Error_Msg_N ("aspect% not allowed", N); 366 return Skip; 367 end if; 368 369 return Abandon; 370 end if; 371 end; 372 373 -- Address attribute definition clause restricted 374 375 elsif Kind = N_Attribute_Definition_Clause 376 and then Get_Attribute_Id (Chars (N)) = 377 Attribute_Address 378 then 379 Error_Msg_Name_1 := Chars (N); 380 381 if Lock_Free_Given then 382 if From_Aspect_Specification (N) then 383 Error_Msg_N ("aspect% not allowed", N); 384 else 385 Error_Msg_N ("% clause not allowed", N); 386 end if; 387 388 return Skip; 389 end if; 390 391 return Abandon; 392 393 -- Non-static Attribute references that don't denote a 394 -- static function restricted. 395 396 elsif Kind = N_Attribute_Reference 397 and then not Is_OK_Static_Expression (N) 398 and then not Is_Static_Function (N) 399 then 400 if Lock_Free_Given then 401 Error_Msg_N 402 ("non-static attribute reference not allowed", N); 403 return Skip; 404 end if; 405 406 return Abandon; 407 408 -- Delay statements restricted 409 410 elsif Kind in N_Delay_Statement then 411 if Lock_Free_Given then 412 Error_Msg_N ("delay not allowed", N); 413 return Skip; 414 end if; 415 416 return Abandon; 417 418 -- Dereferences of access values restricted 419 420 elsif Kind = N_Explicit_Dereference 421 or else (Kind = N_Selected_Component 422 and then Is_Access_Type (Etype (Prefix (N)))) 423 then 424 if Lock_Free_Given then 425 Error_Msg_N 426 ("dereference of access value not allowed", N); 427 return Skip; 428 end if; 429 430 return Abandon; 431 432 -- Non-static function calls restricted 433 434 elsif Kind = N_Function_Call 435 and then not Is_OK_Static_Expression (N) 436 then 437 if Lock_Free_Given then 438 Error_Msg_N 439 ("non-static function call not allowed", N); 440 return Skip; 441 end if; 442 443 return Abandon; 444 445 -- Goto statements restricted 446 447 elsif Kind = N_Goto_Statement then 448 if Lock_Free_Given then 449 Error_Msg_N ("goto statement not allowed", N); 450 return Skip; 451 end if; 452 453 return Abandon; 454 455 -- References 456 457 elsif Kind = N_Identifier 458 and then Present (Entity (N)) 459 then 460 declare 461 Id : constant Entity_Id := Entity (N); 462 Sub_Id : constant Entity_Id := 463 Corresponding_Spec (Sub_Body); 464 465 begin 466 -- Prohibit references to non-constant entities 467 -- outside the protected subprogram scope. 468 469 if Ekind (Id) in Assignable_Kind 470 and then not 471 Scope_Within_Or_Same (Scope (Id), Sub_Id) 472 and then not 473 Scope_Within_Or_Same 474 (Scope (Id), 475 Protected_Body_Subprogram (Sub_Id)) 476 then 477 if Lock_Free_Given then 478 Error_Msg_NE 479 ("reference to global variable& not " & 480 "allowed", N, Id); 481 return Skip; 482 end if; 483 484 return Abandon; 485 end if; 486 end; 487 488 -- Loop statements restricted 489 490 elsif Kind = N_Loop_Statement then 491 if Lock_Free_Given then 492 Error_Msg_N ("loop not allowed", N); 493 return Skip; 494 end if; 495 496 return Abandon; 497 498 -- Pragmas Export and Import restricted 499 500 elsif Kind = N_Pragma then 501 declare 502 Prag_Name : constant Name_Id := 503 Pragma_Name (N); 504 Prag_Id : constant Pragma_Id := 505 Get_Pragma_Id (Prag_Name); 506 507 begin 508 if Prag_Id = Pragma_Export 509 or else Prag_Id = Pragma_Import 510 then 511 Error_Msg_Name_1 := Prag_Name; 512 513 if Lock_Free_Given then 514 if From_Aspect_Specification (N) then 515 Error_Msg_N ("aspect% not allowed", N); 516 else 517 Error_Msg_N ("pragma% not allowed", N); 518 end if; 519 520 return Skip; 521 end if; 522 523 return Abandon; 524 end if; 525 end; 526 527 -- Procedure call statements restricted 528 529 elsif Kind = N_Procedure_Call_Statement then 530 if Lock_Free_Given then 531 Error_Msg_N ("procedure call not allowed", N); 532 return Skip; 533 end if; 534 535 return Abandon; 536 537 -- Quantified expression restricted. Note that we have 538 -- to check the original node as well, since at this 539 -- stage, it may have been rewritten. 540 541 elsif Kind = N_Quantified_Expression 542 or else 543 Nkind (Original_Node (N)) = N_Quantified_Expression 544 then 545 if Lock_Free_Given then 546 Error_Msg_N 547 ("quantified expression not allowed", N); 548 return Skip; 549 end if; 550 551 return Abandon; 552 end if; 553 end if; 554 555 -- A protected subprogram (function or procedure) may 556 -- reference only one component of the protected type, plus 557 -- the type of the component must support atomic operation. 558 559 if Kind = N_Identifier 560 and then Present (Entity (N)) 561 then 562 declare 563 Id : constant Entity_Id := Entity (N); 564 Comp_Decl : Node_Id; 565 Comp_Id : Entity_Id := Empty; 566 Comp_Type : Entity_Id; 567 568 begin 569 if Ekind (Id) = E_Component then 570 Comp_Id := Id; 571 572 elsif Ekind_In (Id, E_Constant, E_Variable) 573 and then Present (Prival_Link (Id)) 574 then 575 Comp_Id := Prival_Link (Id); 576 end if; 577 578 if Present (Comp_Id) then 579 Comp_Decl := Parent (Comp_Id); 580 Comp_Type := Etype (Comp_Id); 581 582 if Nkind (Comp_Decl) = N_Component_Declaration 583 and then Is_List_Member (Comp_Decl) 584 and then List_Containing (Comp_Decl) = Priv_Decls 585 then 586 -- Skip generic types since, in that case, we 587 -- will not build a body anyway (in the generic 588 -- template), and the size in the template may 589 -- have a fake value. 590 591 if not Is_Generic_Type (Comp_Type) then 592 593 -- Make sure the protected component type has 594 -- size and alignment fields set at this 595 -- point whenever this is possible. 596 597 Layout_Type (Comp_Type); 598 599 if not 600 Support_Atomic_Primitives (Comp_Type) 601 then 602 if Lock_Free_Given then 603 Error_Msg_NE 604 ("type of& must support atomic " & 605 "operations", 606 N, Comp_Id); 607 return Skip; 608 end if; 609 610 return Abandon; 611 end if; 612 end if; 613 614 -- Check if another protected component has 615 -- already been accessed by the subprogram body. 616 617 if No (Comp) then 618 Comp := Comp_Id; 619 620 elsif Comp /= Comp_Id then 621 if Lock_Free_Given then 622 Error_Msg_N 623 ("only one protected component allowed", 624 N); 625 return Skip; 626 end if; 627 628 return Abandon; 629 end if; 630 end if; 631 end if; 632 end; 633 end if; 634 635 return OK; 636 end Check_Node; 637 638 function Check_All_Nodes is new Traverse_Func (Check_Node); 639 640 -- Start of processing for Satisfies_Lock_Free_Requirements 641 642 begin 643 -- Get the number of errors detected by the compiler so far 644 645 if Lock_Free_Given then 646 Errors_Count := Serious_Errors_Detected; 647 end if; 648 649 if Check_All_Nodes (Sub_Body) = OK 650 and then (not Lock_Free_Given 651 or else Errors_Count = Serious_Errors_Detected) 652 then 653 -- Establish a relation between the subprogram body and the 654 -- unique protected component it references. 655 656 if Present (Comp) then 657 Lock_Free_Subprogram_Table.Append 658 (Lock_Free_Subprogram'(Sub_Body, Comp)); 659 end if; 660 661 return True; 662 else 663 return False; 664 end if; 665 end Satisfies_Lock_Free_Requirements; 666 667 -- Start of processing for Protected_Body_Case 668 669 begin 670 Decl := First (Decls); 671 while Present (Decl) loop 672 if Nkind (Decl) = N_Subprogram_Body 673 and then not Satisfies_Lock_Free_Requirements (Decl) 674 then 675 if Lock_Free_Given then 676 Error_Msg_N 677 ("illegal body when Lock_Free given", Decl); 678 else 679 return False; 680 end if; 681 end if; 682 683 Next (Decl); 684 end loop; 685 end Protected_Body_Case; 686 end if; 687 688 -- When Lock_Free is given, check if no error has been detected during 689 -- the process. 690 691 if Lock_Free_Given 692 and then Errors_Count /= Serious_Errors_Detected 693 then 694 return False; 695 end if; 696 697 return True; 698 end Allows_Lock_Free_Implementation; 699 700 ----------------------------- 701 -- Analyze_Abort_Statement -- 702 ----------------------------- 703 704 procedure Analyze_Abort_Statement (N : Node_Id) is 705 T_Name : Node_Id; 706 707 begin 708 Tasking_Used := True; 709 Check_SPARK_05_Restriction ("abort statement is not allowed", N); 710 711 T_Name := First (Names (N)); 712 while Present (T_Name) loop 713 Analyze (T_Name); 714 715 if Is_Task_Type (Etype (T_Name)) 716 or else (Ada_Version >= Ada_2005 717 and then Ekind (Etype (T_Name)) = E_Class_Wide_Type 718 and then Is_Interface (Etype (T_Name)) 719 and then Is_Task_Interface (Etype (T_Name))) 720 then 721 Resolve (T_Name); 722 else 723 if Ada_Version >= Ada_2005 then 724 Error_Msg_N ("expect task name or task interface class-wide " 725 & "object for ABORT", T_Name); 726 else 727 Error_Msg_N ("expect task name for ABORT", T_Name); 728 end if; 729 730 return; 731 end if; 732 733 Next (T_Name); 734 end loop; 735 736 Check_Restriction (No_Abort_Statements, N); 737 Check_Potentially_Blocking_Operation (N); 738 end Analyze_Abort_Statement; 739 740 -------------------------------- 741 -- Analyze_Accept_Alternative -- 742 -------------------------------- 743 744 procedure Analyze_Accept_Alternative (N : Node_Id) is 745 begin 746 Tasking_Used := True; 747 748 if Present (Pragmas_Before (N)) then 749 Analyze_List (Pragmas_Before (N)); 750 end if; 751 752 if Present (Condition (N)) then 753 Analyze_And_Resolve (Condition (N), Any_Boolean); 754 end if; 755 756 Analyze (Accept_Statement (N)); 757 758 if Is_Non_Empty_List (Statements (N)) then 759 Analyze_Statements (Statements (N)); 760 end if; 761 end Analyze_Accept_Alternative; 762 763 ------------------------------ 764 -- Analyze_Accept_Statement -- 765 ------------------------------ 766 767 procedure Analyze_Accept_Statement (N : Node_Id) is 768 Nam : constant Entity_Id := Entry_Direct_Name (N); 769 Formals : constant List_Id := Parameter_Specifications (N); 770 Index : constant Node_Id := Entry_Index (N); 771 Stats : constant Node_Id := Handled_Statement_Sequence (N); 772 Accept_Id : Entity_Id; 773 Entry_Nam : Entity_Id; 774 E : Entity_Id; 775 Kind : Entity_Kind; 776 Task_Nam : Entity_Id := Empty; -- initialize to prevent warning 777 778 begin 779 Tasking_Used := True; 780 Check_SPARK_05_Restriction ("accept statement is not allowed", N); 781 782 -- Entry name is initialized to Any_Id. It should get reset to the 783 -- matching entry entity. An error is signalled if it is not reset. 784 785 Entry_Nam := Any_Id; 786 787 for J in reverse 0 .. Scope_Stack.Last loop 788 Task_Nam := Scope_Stack.Table (J).Entity; 789 exit when Ekind (Etype (Task_Nam)) = E_Task_Type; 790 Kind := Ekind (Task_Nam); 791 792 if Kind /= E_Block and then Kind /= E_Loop 793 and then not Is_Entry (Task_Nam) 794 then 795 Error_Msg_N ("enclosing body of accept must be a task", N); 796 return; 797 end if; 798 end loop; 799 800 if Ekind (Etype (Task_Nam)) /= E_Task_Type then 801 Error_Msg_N ("invalid context for accept statement", N); 802 return; 803 end if; 804 805 -- In order to process the parameters, we create a defining identifier 806 -- that can be used as the name of the scope. The name of the accept 807 -- statement itself is not a defining identifier, and we cannot use 808 -- its name directly because the task may have any number of accept 809 -- statements for the same entry. 810 811 if Present (Index) then 812 Accept_Id := New_Internal_Entity 813 (E_Entry_Family, Current_Scope, Sloc (N), 'E'); 814 else 815 Accept_Id := New_Internal_Entity 816 (E_Entry, Current_Scope, Sloc (N), 'E'); 817 end if; 818 819 Set_Etype (Accept_Id, Standard_Void_Type); 820 Set_Accept_Address (Accept_Id, New_Elmt_List); 821 822 if Present (Formals) then 823 Push_Scope (Accept_Id); 824 Process_Formals (Formals, N); 825 Create_Extra_Formals (Accept_Id); 826 End_Scope; 827 end if; 828 829 -- We set the default expressions processed flag because we don't need 830 -- default expression functions. This is really more like body entity 831 -- than a spec entity anyway. 832 833 Set_Default_Expressions_Processed (Accept_Id); 834 835 E := First_Entity (Etype (Task_Nam)); 836 while Present (E) loop 837 if Chars (E) = Chars (Nam) 838 and then (Ekind (E) = Ekind (Accept_Id)) 839 and then Type_Conformant (Accept_Id, E) 840 then 841 Entry_Nam := E; 842 exit; 843 end if; 844 845 Next_Entity (E); 846 end loop; 847 848 if Entry_Nam = Any_Id then 849 Error_Msg_N ("no entry declaration matches accept statement", N); 850 return; 851 else 852 Set_Entity (Nam, Entry_Nam); 853 Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False); 854 Style.Check_Identifier (Nam, Entry_Nam); 855 end if; 856 857 -- Verify that the entry is not hidden by a procedure declared in the 858 -- current block (pathological but possible). 859 860 if Current_Scope /= Task_Nam then 861 declare 862 E1 : Entity_Id; 863 864 begin 865 E1 := First_Entity (Current_Scope); 866 while Present (E1) loop 867 if Ekind (E1) = E_Procedure 868 and then Chars (E1) = Chars (Entry_Nam) 869 and then Type_Conformant (E1, Entry_Nam) 870 then 871 Error_Msg_N ("entry name is not visible", N); 872 end if; 873 874 Next_Entity (E1); 875 end loop; 876 end; 877 end if; 878 879 Set_Convention (Accept_Id, Convention (Entry_Nam)); 880 Check_Fully_Conformant (Accept_Id, Entry_Nam, N); 881 882 for J in reverse 0 .. Scope_Stack.Last loop 883 exit when Task_Nam = Scope_Stack.Table (J).Entity; 884 885 if Entry_Nam = Scope_Stack.Table (J).Entity then 886 Error_Msg_N ("duplicate accept statement for same entry", N); 887 end if; 888 end loop; 889 890 declare 891 P : Node_Id := N; 892 begin 893 loop 894 P := Parent (P); 895 case Nkind (P) is 896 when N_Compilation_Unit 897 | N_Task_Body 898 => 899 exit; 900 901 when N_Asynchronous_Select => 902 Error_Msg_N 903 ("accept statements are not allowed within an " 904 & "asynchronous select inner to the enclosing task body", 905 N); 906 exit; 907 908 when others => 909 null; 910 end case; 911 end loop; 912 end; 913 914 if Ekind (E) = E_Entry_Family then 915 if No (Index) then 916 Error_Msg_N ("missing entry index in accept for entry family", N); 917 else 918 Analyze_And_Resolve (Index, Entry_Index_Type (E)); 919 Apply_Range_Check (Index, Entry_Index_Type (E)); 920 end if; 921 922 elsif Present (Index) then 923 Error_Msg_N ("invalid entry index in accept for simple entry", N); 924 end if; 925 926 -- If label declarations present, analyze them. They are declared in the 927 -- enclosing task, but their enclosing scope is the entry itself, so 928 -- that goto's to the label are recognized as local to the accept. 929 930 if Present (Declarations (N)) then 931 declare 932 Decl : Node_Id; 933 Id : Entity_Id; 934 935 begin 936 Decl := First (Declarations (N)); 937 while Present (Decl) loop 938 Analyze (Decl); 939 940 pragma Assert 941 (Nkind (Decl) = N_Implicit_Label_Declaration); 942 943 Id := Defining_Identifier (Decl); 944 Set_Enclosing_Scope (Id, Entry_Nam); 945 Next (Decl); 946 end loop; 947 end; 948 end if; 949 950 -- If statements are present, they must be analyzed in the context of 951 -- the entry, so that references to formals are correctly resolved. We 952 -- also have to add the declarations that are required by the expansion 953 -- of the accept statement in this case if expansion active. 954 955 -- In the case of a select alternative of a selective accept, the 956 -- expander references the address declaration even if there is no 957 -- statement list. 958 959 -- We also need to create the renaming declarations for the local 960 -- variables that will replace references to the formals within the 961 -- accept statement. 962 963 Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam); 964 965 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value 966 -- fields on all entry formals (this loop ignores all other entities). 967 -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as 968 -- well, so that we can post accurate warnings on each accept statement 969 -- for the same entry. 970 971 E := First_Entity (Entry_Nam); 972 while Present (E) loop 973 if Is_Formal (E) then 974 Set_Never_Set_In_Source (E, True); 975 Set_Is_True_Constant (E, False); 976 Set_Current_Value (E, Empty); 977 Set_Referenced (E, False); 978 Set_Referenced_As_LHS (E, False); 979 Set_Referenced_As_Out_Parameter (E, False); 980 Set_Has_Pragma_Unreferenced (E, False); 981 end if; 982 983 Next_Entity (E); 984 end loop; 985 986 -- Analyze statements if present 987 988 if Present (Stats) then 989 Push_Scope (Entry_Nam); 990 Install_Declarations (Entry_Nam); 991 992 Set_Actual_Subtypes (N, Current_Scope); 993 994 Analyze (Stats); 995 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam); 996 End_Scope; 997 end if; 998 999 -- Some warning checks 1000 1001 Check_Potentially_Blocking_Operation (N); 1002 Check_References (Entry_Nam, N); 1003 Set_Entry_Accepted (Entry_Nam); 1004 end Analyze_Accept_Statement; 1005 1006 --------------------------------- 1007 -- Analyze_Asynchronous_Select -- 1008 --------------------------------- 1009 1010 procedure Analyze_Asynchronous_Select (N : Node_Id) is 1011 Is_Disp_Select : Boolean := False; 1012 Trigger : Node_Id; 1013 1014 begin 1015 Tasking_Used := True; 1016 Check_SPARK_05_Restriction ("select statement is not allowed", N); 1017 Check_Restriction (Max_Asynchronous_Select_Nesting, N); 1018 Check_Restriction (No_Select_Statements, N); 1019 1020 if Ada_Version >= Ada_2005 then 1021 Trigger := Triggering_Statement (Triggering_Alternative (N)); 1022 1023 Analyze (Trigger); 1024 1025 -- Ada 2005 (AI-345): Check for a potential dispatching select 1026 1027 Check_Triggering_Statement (Trigger, N, Is_Disp_Select); 1028 end if; 1029 1030 -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous 1031 -- select will have to duplicate the triggering statements. Postpone 1032 -- the analysis of the statements till expansion. Analyze only if the 1033 -- expander is disabled in order to catch any semantic errors. 1034 1035 if Is_Disp_Select then 1036 if not Expander_Active then 1037 Analyze_Statements (Statements (Abortable_Part (N))); 1038 Analyze (Triggering_Alternative (N)); 1039 end if; 1040 1041 -- Analyze the statements. We analyze statements in the abortable part, 1042 -- because this is the section that is executed first, and that way our 1043 -- remembering of saved values and checks is accurate. 1044 1045 else 1046 Analyze_Statements (Statements (Abortable_Part (N))); 1047 Analyze (Triggering_Alternative (N)); 1048 end if; 1049 end Analyze_Asynchronous_Select; 1050 1051 ------------------------------------ 1052 -- Analyze_Conditional_Entry_Call -- 1053 ------------------------------------ 1054 1055 procedure Analyze_Conditional_Entry_Call (N : Node_Id) is 1056 Trigger : constant Node_Id := 1057 Entry_Call_Statement (Entry_Call_Alternative (N)); 1058 Is_Disp_Select : Boolean := False; 1059 1060 begin 1061 Tasking_Used := True; 1062 Check_SPARK_05_Restriction ("select statement is not allowed", N); 1063 Check_Restriction (No_Select_Statements, N); 1064 1065 -- Ada 2005 (AI-345): The trigger may be a dispatching call 1066 1067 if Ada_Version >= Ada_2005 then 1068 Analyze (Trigger); 1069 Check_Triggering_Statement (Trigger, N, Is_Disp_Select); 1070 end if; 1071 1072 if List_Length (Else_Statements (N)) = 1 1073 and then Nkind (First (Else_Statements (N))) in N_Delay_Statement 1074 then 1075 Error_Msg_N 1076 ("suspicious form of conditional entry call??!", N); 1077 Error_Msg_N 1078 ("\`SELECT OR` may be intended rather than `SELECT ELSE`??!", N); 1079 end if; 1080 1081 -- Postpone the analysis of the statements till expansion. Analyze only 1082 -- if the expander is disabled in order to catch any semantic errors. 1083 1084 if Is_Disp_Select then 1085 if not Expander_Active then 1086 Analyze (Entry_Call_Alternative (N)); 1087 Analyze_Statements (Else_Statements (N)); 1088 end if; 1089 1090 -- Regular select analysis 1091 1092 else 1093 Analyze (Entry_Call_Alternative (N)); 1094 Analyze_Statements (Else_Statements (N)); 1095 end if; 1096 end Analyze_Conditional_Entry_Call; 1097 1098 -------------------------------- 1099 -- Analyze_Delay_Alternative -- 1100 -------------------------------- 1101 1102 procedure Analyze_Delay_Alternative (N : Node_Id) is 1103 Expr : Node_Id; 1104 Typ : Entity_Id; 1105 1106 begin 1107 Tasking_Used := True; 1108 Check_Restriction (No_Delay, N); 1109 1110 if Present (Pragmas_Before (N)) then 1111 Analyze_List (Pragmas_Before (N)); 1112 end if; 1113 1114 if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then 1115 Expr := Expression (Delay_Statement (N)); 1116 1117 -- Defer full analysis until the statement is expanded, to insure 1118 -- that generated code does not move past the guard. The delay 1119 -- expression is only evaluated if the guard is open. 1120 1121 if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then 1122 Preanalyze_And_Resolve (Expr, Standard_Duration); 1123 else 1124 Preanalyze_And_Resolve (Expr); 1125 end if; 1126 1127 Typ := First_Subtype (Etype (Expr)); 1128 1129 if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement 1130 and then not Is_RTE (Typ, RO_CA_Time) 1131 and then not Is_RTE (Typ, RO_RT_Time) 1132 then 1133 Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr); 1134 end if; 1135 1136 Check_Restriction (No_Fixed_Point, Expr); 1137 1138 else 1139 Analyze (Delay_Statement (N)); 1140 end if; 1141 1142 if Present (Condition (N)) then 1143 Analyze_And_Resolve (Condition (N), Any_Boolean); 1144 end if; 1145 1146 if Is_Non_Empty_List (Statements (N)) then 1147 Analyze_Statements (Statements (N)); 1148 end if; 1149 end Analyze_Delay_Alternative; 1150 1151 ---------------------------- 1152 -- Analyze_Delay_Relative -- 1153 ---------------------------- 1154 1155 procedure Analyze_Delay_Relative (N : Node_Id) is 1156 E : constant Node_Id := Expression (N); 1157 1158 begin 1159 Tasking_Used := True; 1160 Check_SPARK_05_Restriction ("delay statement is not allowed", N); 1161 Check_Restriction (No_Relative_Delay, N); 1162 Check_Restriction (No_Delay, N); 1163 Check_Potentially_Blocking_Operation (N); 1164 Analyze_And_Resolve (E, Standard_Duration); 1165 Check_Restriction (No_Fixed_Point, E); 1166 1167 -- In SPARK mode the relative delay statement introduces an implicit 1168 -- dependency on the Ada.Real_Time.Clock_Time abstract state, so we must 1169 -- force the loading of the Ada.Real_Time package. 1170 1171 if GNATprove_Mode then 1172 SPARK_Implicit_Load (RO_RT_Time); 1173 end if; 1174 end Analyze_Delay_Relative; 1175 1176 ------------------------- 1177 -- Analyze_Delay_Until -- 1178 ------------------------- 1179 1180 procedure Analyze_Delay_Until (N : Node_Id) is 1181 E : constant Node_Id := Expression (N); 1182 Typ : Entity_Id; 1183 1184 begin 1185 Tasking_Used := True; 1186 Check_SPARK_05_Restriction ("delay statement is not allowed", N); 1187 Check_Restriction (No_Delay, N); 1188 Check_Potentially_Blocking_Operation (N); 1189 Analyze_And_Resolve (E); 1190 Typ := First_Subtype (Etype (E)); 1191 1192 if not Is_RTE (Typ, RO_CA_Time) and then 1193 not Is_RTE (Typ, RO_RT_Time) 1194 then 1195 Error_Msg_N ("expect Time types for `DELAY UNTIL`", E); 1196 end if; 1197 end Analyze_Delay_Until; 1198 1199 ------------------------ 1200 -- Analyze_Entry_Body -- 1201 ------------------------ 1202 1203 procedure Analyze_Entry_Body (N : Node_Id) is 1204 Id : constant Entity_Id := Defining_Identifier (N); 1205 Decls : constant List_Id := Declarations (N); 1206 Stats : constant Node_Id := Handled_Statement_Sequence (N); 1207 Formals : constant Node_Id := Entry_Body_Formal_Part (N); 1208 P_Type : constant Entity_Id := Current_Scope; 1209 E : Entity_Id; 1210 Entry_Name : Entity_Id; 1211 1212 begin 1213 -- An entry body freezes the contract of the nearest enclosing package 1214 -- body and all other contracts encountered in the same declarative part 1215 -- up to and excluding the entry body. This ensures that any annotations 1216 -- referenced by the contract of an entry or subprogram body declared 1217 -- within the current protected body are available. 1218 1219 Freeze_Previous_Contracts (N); 1220 1221 Tasking_Used := True; 1222 1223 -- Entry_Name is initialized to Any_Id. It should get reset to the 1224 -- matching entry entity. An error is signalled if it is not reset. 1225 1226 Entry_Name := Any_Id; 1227 1228 Analyze (Formals); 1229 1230 if Present (Entry_Index_Specification (Formals)) then 1231 Set_Ekind (Id, E_Entry_Family); 1232 else 1233 Set_Ekind (Id, E_Entry); 1234 end if; 1235 1236 Set_Etype (Id, Standard_Void_Type); 1237 Set_Scope (Id, Current_Scope); 1238 Set_Accept_Address (Id, New_Elmt_List); 1239 1240 -- Set the SPARK_Mode from the current context (may be overwritten later 1241 -- with an explicit pragma). 1242 1243 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 1244 Set_SPARK_Pragma_Inherited (Id); 1245 1246 -- Analyze any aspect specifications that appear on the entry body 1247 1248 if Has_Aspects (N) then 1249 Analyze_Aspect_Specifications_On_Body_Or_Stub (N); 1250 end if; 1251 1252 E := First_Entity (P_Type); 1253 while Present (E) loop 1254 if Chars (E) = Chars (Id) 1255 and then (Ekind (E) = Ekind (Id)) 1256 and then Type_Conformant (Id, E) 1257 then 1258 Entry_Name := E; 1259 Set_Convention (Id, Convention (E)); 1260 Set_Corresponding_Body (Parent (E), Id); 1261 Check_Fully_Conformant (Id, E, N); 1262 1263 if Ekind (Id) = E_Entry_Family then 1264 if not Fully_Conformant_Discrete_Subtypes ( 1265 Discrete_Subtype_Definition (Parent (E)), 1266 Discrete_Subtype_Definition 1267 (Entry_Index_Specification (Formals))) 1268 then 1269 Error_Msg_N 1270 ("index not fully conformant with previous declaration", 1271 Discrete_Subtype_Definition 1272 (Entry_Index_Specification (Formals))); 1273 1274 else 1275 -- The elaboration of the entry body does not recompute the 1276 -- bounds of the index, which may have side effects. Inherit 1277 -- the bounds from the entry declaration. This is critical 1278 -- if the entry has a per-object constraint. If a bound is 1279 -- given by a discriminant, it must be reanalyzed in order 1280 -- to capture the discriminal of the current entry, rather 1281 -- than that of the protected type. 1282 1283 declare 1284 Index_Spec : constant Node_Id := 1285 Entry_Index_Specification (Formals); 1286 1287 Def : constant Node_Id := 1288 New_Copy_Tree 1289 (Discrete_Subtype_Definition (Parent (E))); 1290 1291 begin 1292 if Nkind 1293 (Original_Node 1294 (Discrete_Subtype_Definition (Index_Spec))) = N_Range 1295 then 1296 Set_Etype (Def, Empty); 1297 Set_Analyzed (Def, False); 1298 1299 -- Keep the original subtree to ensure a properly 1300 -- formed tree (e.g. for ASIS use). 1301 1302 Rewrite 1303 (Discrete_Subtype_Definition (Index_Spec), Def); 1304 1305 Set_Analyzed (Low_Bound (Def), False); 1306 Set_Analyzed (High_Bound (Def), False); 1307 1308 if Denotes_Discriminant (Low_Bound (Def)) then 1309 Set_Entity (Low_Bound (Def), Empty); 1310 end if; 1311 1312 if Denotes_Discriminant (High_Bound (Def)) then 1313 Set_Entity (High_Bound (Def), Empty); 1314 end if; 1315 1316 Analyze (Def); 1317 Make_Index (Def, Index_Spec); 1318 Set_Etype 1319 (Defining_Identifier (Index_Spec), Etype (Def)); 1320 end if; 1321 end; 1322 end if; 1323 end if; 1324 1325 exit; 1326 end if; 1327 1328 Next_Entity (E); 1329 end loop; 1330 1331 if Entry_Name = Any_Id then 1332 Error_Msg_N ("no entry declaration matches entry body", N); 1333 return; 1334 1335 elsif Has_Completion (Entry_Name) then 1336 Error_Msg_N ("duplicate entry body", N); 1337 return; 1338 1339 else 1340 Set_Has_Completion (Entry_Name); 1341 Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False); 1342 Style.Check_Identifier (Id, Entry_Name); 1343 end if; 1344 1345 Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); 1346 Push_Scope (Entry_Name); 1347 1348 Install_Declarations (Entry_Name); 1349 Set_Actual_Subtypes (N, Current_Scope); 1350 1351 -- The entity for the protected subprogram corresponding to the entry 1352 -- has been created. We retain the name of this entity in the entry 1353 -- body, for use when the corresponding subprogram body is created. 1354 -- Note that entry bodies have no Corresponding_Spec, and there is no 1355 -- easy link back in the tree between the entry body and the entity for 1356 -- the entry itself, which is why we must propagate some attributes 1357 -- explicitly from spec to body. 1358 1359 Set_Protected_Body_Subprogram 1360 (Id, Protected_Body_Subprogram (Entry_Name)); 1361 1362 Set_Entry_Parameters_Type 1363 (Id, Entry_Parameters_Type (Entry_Name)); 1364 1365 -- Add a declaration for the Protection object, renaming declarations 1366 -- for the discriminals and privals and finally a declaration for the 1367 -- entry family index (if applicable). 1368 1369 if Expander_Active 1370 and then Is_Protected_Type (P_Type) 1371 then 1372 Install_Private_Data_Declarations 1373 (Sloc (N), Entry_Name, P_Type, N, Decls); 1374 end if; 1375 1376 if Present (Decls) then 1377 Analyze_Declarations (Decls); 1378 Inspect_Deferred_Constant_Completion (Decls); 1379 end if; 1380 1381 -- Process the contract of the subprogram body after all declarations 1382 -- have been analyzed. This ensures that any contract-related pragmas 1383 -- are available through the N_Contract node of the body. 1384 1385 Analyze_Entry_Or_Subprogram_Body_Contract (Id); 1386 1387 if Present (Stats) then 1388 Analyze (Stats); 1389 end if; 1390 1391 -- Check for unreferenced variables etc. Before the Check_References 1392 -- call, we transfer Never_Set_In_Source and Referenced flags from 1393 -- parameters in the spec to the corresponding entities in the body, 1394 -- since we want the warnings on the body entities. Note that we do not 1395 -- have to transfer Referenced_As_LHS, since that flag can only be set 1396 -- for simple variables, but we include Has_Pragma_Unreferenced, 1397 -- which may have been specified for a formal in the body. 1398 1399 -- At the same time, we set the flags on the spec entities to suppress 1400 -- any warnings on the spec formals, since we also scan the spec. 1401 -- Finally, we propagate the Entry_Component attribute to the body 1402 -- formals, for use in the renaming declarations created later for the 1403 -- formals (see exp_ch9.Add_Formal_Renamings). 1404 1405 declare 1406 E1 : Entity_Id; 1407 E2 : Entity_Id; 1408 1409 begin 1410 E1 := First_Entity (Entry_Name); 1411 while Present (E1) loop 1412 E2 := First_Entity (Id); 1413 while Present (E2) loop 1414 exit when Chars (E1) = Chars (E2); 1415 Next_Entity (E2); 1416 end loop; 1417 1418 -- If no matching body entity, then we already had a detected 1419 -- error of some kind, so just don't worry about these warnings. 1420 1421 if No (E2) then 1422 goto Continue; 1423 end if; 1424 1425 if Ekind (E1) = E_Out_Parameter then 1426 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1)); 1427 Set_Never_Set_In_Source (E1, False); 1428 end if; 1429 1430 Set_Referenced (E2, Referenced (E1)); 1431 Set_Referenced (E1); 1432 Set_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (E1)); 1433 Set_Entry_Component (E2, Entry_Component (E1)); 1434 1435 <<Continue>> 1436 Next_Entity (E1); 1437 end loop; 1438 1439 Check_References (Id); 1440 end; 1441 1442 -- We still need to check references for the spec, since objects 1443 -- declared in the body are chained (in the First_Entity sense) to 1444 -- the spec rather than the body in the case of entries. 1445 1446 Check_References (Entry_Name); 1447 1448 -- Process the end label, and terminate the scope 1449 1450 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); 1451 Update_Use_Clause_Chain; 1452 End_Scope; 1453 1454 -- If this is an entry family, remove the loop created to provide 1455 -- a scope for the entry index. 1456 1457 if Ekind (Id) = E_Entry_Family 1458 and then Present (Entry_Index_Specification (Formals)) 1459 then 1460 End_Scope; 1461 end if; 1462 end Analyze_Entry_Body; 1463 1464 ------------------------------------ 1465 -- Analyze_Entry_Body_Formal_Part -- 1466 ------------------------------------ 1467 1468 procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is 1469 Id : constant Entity_Id := Defining_Identifier (Parent (N)); 1470 Index : constant Node_Id := Entry_Index_Specification (N); 1471 Formals : constant List_Id := Parameter_Specifications (N); 1472 1473 begin 1474 Tasking_Used := True; 1475 1476 if Present (Index) then 1477 Analyze (Index); 1478 1479 -- The entry index functions like a loop variable, thus it is known 1480 -- to have a valid value. 1481 1482 Set_Is_Known_Valid (Defining_Identifier (Index)); 1483 end if; 1484 1485 if Present (Formals) then 1486 Set_Scope (Id, Current_Scope); 1487 Push_Scope (Id); 1488 Process_Formals (Formals, Parent (N)); 1489 End_Scope; 1490 end if; 1491 end Analyze_Entry_Body_Formal_Part; 1492 1493 ------------------------------------ 1494 -- Analyze_Entry_Call_Alternative -- 1495 ------------------------------------ 1496 1497 procedure Analyze_Entry_Call_Alternative (N : Node_Id) is 1498 Call : constant Node_Id := Entry_Call_Statement (N); 1499 1500 begin 1501 Tasking_Used := True; 1502 Check_SPARK_05_Restriction ("entry call is not allowed", N); 1503 1504 if Present (Pragmas_Before (N)) then 1505 Analyze_List (Pragmas_Before (N)); 1506 end if; 1507 1508 if Nkind (Call) = N_Attribute_Reference then 1509 1510 -- Possibly a stream attribute, but definitely illegal. Other 1511 -- illegalities, such as procedure calls, are diagnosed after 1512 -- resolution. 1513 1514 Error_Msg_N ("entry call alternative requires an entry call", Call); 1515 return; 1516 end if; 1517 1518 Analyze (Call); 1519 1520 -- An indirect call in this context is illegal. A procedure call that 1521 -- does not involve a renaming of an entry is illegal as well, but this 1522 -- and other semantic errors are caught during resolution. 1523 1524 if Nkind (Call) = N_Explicit_Dereference then 1525 Error_Msg_N 1526 ("entry call or dispatching primitive of interface required ", N); 1527 end if; 1528 1529 if Is_Non_Empty_List (Statements (N)) then 1530 Analyze_Statements (Statements (N)); 1531 end if; 1532 end Analyze_Entry_Call_Alternative; 1533 1534 ------------------------------- 1535 -- Analyze_Entry_Declaration -- 1536 ------------------------------- 1537 1538 procedure Analyze_Entry_Declaration (N : Node_Id) is 1539 D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); 1540 Def_Id : constant Entity_Id := Defining_Identifier (N); 1541 Formals : constant List_Id := Parameter_Specifications (N); 1542 1543 begin 1544 Generate_Definition (Def_Id); 1545 1546 Tasking_Used := True; 1547 1548 -- Case of no discrete subtype definition 1549 1550 if No (D_Sdef) then 1551 Set_Ekind (Def_Id, E_Entry); 1552 1553 -- Processing for discrete subtype definition present 1554 1555 else 1556 Enter_Name (Def_Id); 1557 Set_Ekind (Def_Id, E_Entry_Family); 1558 Analyze (D_Sdef); 1559 Make_Index (D_Sdef, N, Def_Id); 1560 1561 -- Check subtype with predicate in entry family 1562 1563 Bad_Predicated_Subtype_Use 1564 ("subtype& has predicate, not allowed in entry family", 1565 D_Sdef, Etype (D_Sdef)); 1566 1567 -- Check entry family static bounds outside allowed limits 1568 1569 -- Note: originally this check was not performed here, but in that 1570 -- case the check happens deep in the expander, and the message is 1571 -- posted at the wrong location, and omitted in -gnatc mode. 1572 -- If the type of the entry index is a generic formal, no check 1573 -- is possible. In an instance, the check is not static and a run- 1574 -- time exception will be raised if the bounds are unreasonable. 1575 1576 declare 1577 PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index); 1578 LB : constant Uint := Expr_Value (Type_Low_Bound (PEI)); 1579 UB : constant Uint := Expr_Value (Type_High_Bound (PEI)); 1580 1581 LBR : Node_Id; 1582 UBR : Node_Id; 1583 1584 begin 1585 1586 -- No bounds checking if the type is generic or if previous error. 1587 -- In an instance the check is dynamic. 1588 1589 if Is_Generic_Type (Etype (D_Sdef)) 1590 or else In_Instance 1591 or else Error_Posted (D_Sdef) 1592 then 1593 goto Skip_LB; 1594 1595 elsif Nkind (D_Sdef) = N_Range then 1596 LBR := Low_Bound (D_Sdef); 1597 1598 elsif Is_Entity_Name (D_Sdef) 1599 and then Is_Type (Entity (D_Sdef)) 1600 then 1601 LBR := Type_Low_Bound (Entity (D_Sdef)); 1602 1603 else 1604 goto Skip_LB; 1605 end if; 1606 1607 if Is_OK_Static_Expression (LBR) 1608 and then Expr_Value (LBR) < LB 1609 then 1610 Error_Msg_Uint_1 := LB; 1611 Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef); 1612 end if; 1613 1614 <<Skip_LB>> 1615 if Is_Generic_Type (Etype (D_Sdef)) 1616 or else In_Instance 1617 or else Error_Posted (D_Sdef) 1618 then 1619 goto Skip_UB; 1620 1621 elsif Nkind (D_Sdef) = N_Range then 1622 UBR := High_Bound (D_Sdef); 1623 1624 elsif Is_Entity_Name (D_Sdef) 1625 and then Is_Type (Entity (D_Sdef)) 1626 then 1627 UBR := Type_High_Bound (Entity (D_Sdef)); 1628 1629 else 1630 goto Skip_UB; 1631 end if; 1632 1633 if Is_OK_Static_Expression (UBR) 1634 and then Expr_Value (UBR) > UB 1635 then 1636 Error_Msg_Uint_1 := UB; 1637 Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef); 1638 end if; 1639 1640 <<Skip_UB>> 1641 null; 1642 end; 1643 end if; 1644 1645 -- Decorate Def_Id 1646 1647 Set_Etype (Def_Id, Standard_Void_Type); 1648 Set_Convention (Def_Id, Convention_Entry); 1649 Set_Accept_Address (Def_Id, New_Elmt_List); 1650 1651 -- Set the SPARK_Mode from the current context (may be overwritten later 1652 -- with an explicit pragma). Task entries are excluded because they are 1653 -- not completed by entry bodies. 1654 1655 if Ekind (Current_Scope) = E_Protected_Type then 1656 Set_SPARK_Pragma (Def_Id, SPARK_Mode_Pragma); 1657 Set_SPARK_Pragma_Inherited (Def_Id); 1658 end if; 1659 1660 -- Preserve relevant elaboration-related attributes of the context which 1661 -- are no longer available or very expensive to recompute once analysis, 1662 -- resolution, and expansion are over. 1663 1664 Mark_Elaboration_Attributes 1665 (N_Id => Def_Id, 1666 Checks => True); 1667 1668 -- Process formals 1669 1670 if Present (Formals) then 1671 Set_Scope (Def_Id, Current_Scope); 1672 Push_Scope (Def_Id); 1673 Process_Formals (Formals, N); 1674 Create_Extra_Formals (Def_Id); 1675 End_Scope; 1676 end if; 1677 1678 if Ekind (Def_Id) = E_Entry then 1679 New_Overloaded_Entity (Def_Id); 1680 end if; 1681 1682 Generate_Reference_To_Formals (Def_Id); 1683 1684 if Has_Aspects (N) then 1685 Analyze_Aspect_Specifications (N, Def_Id); 1686 end if; 1687 end Analyze_Entry_Declaration; 1688 1689 --------------------------------------- 1690 -- Analyze_Entry_Index_Specification -- 1691 --------------------------------------- 1692 1693 -- The Defining_Identifier of the entry index specification is local to the 1694 -- entry body, but it must be available in the entry barrier which is 1695 -- evaluated outside of the entry body. The index is eventually renamed as 1696 -- a run-time object, so its visibility is strictly a front-end concern. In 1697 -- order to make it available to the barrier, we create an additional 1698 -- scope, as for a loop, whose only declaration is the index name. This 1699 -- loop is not attached to the tree and does not appear as an entity local 1700 -- to the protected type, so its existence need only be known to routines 1701 -- that process entry families. 1702 1703 procedure Analyze_Entry_Index_Specification (N : Node_Id) is 1704 Iden : constant Node_Id := Defining_Identifier (N); 1705 Def : constant Node_Id := Discrete_Subtype_Definition (N); 1706 Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); 1707 1708 begin 1709 Tasking_Used := True; 1710 Analyze (Def); 1711 1712 -- There is no elaboration of the entry index specification. Therefore, 1713 -- if the index is a range, it is not resolved and expanded, but the 1714 -- bounds are inherited from the entry declaration, and reanalyzed. 1715 -- See Analyze_Entry_Body. 1716 1717 if Nkind (Def) /= N_Range then 1718 Make_Index (Def, N); 1719 end if; 1720 1721 Set_Ekind (Loop_Id, E_Loop); 1722 Set_Scope (Loop_Id, Current_Scope); 1723 Push_Scope (Loop_Id); 1724 Enter_Name (Iden); 1725 Set_Ekind (Iden, E_Entry_Index_Parameter); 1726 Set_Etype (Iden, Etype (Def)); 1727 end Analyze_Entry_Index_Specification; 1728 1729 ---------------------------- 1730 -- Analyze_Protected_Body -- 1731 ---------------------------- 1732 1733 procedure Analyze_Protected_Body (N : Node_Id) is 1734 Body_Id : constant Entity_Id := Defining_Identifier (N); 1735 Last_E : Entity_Id; 1736 1737 Spec_Id : Entity_Id; 1738 -- This is initially the entity of the protected object or protected 1739 -- type involved, but is replaced by the protected type always in the 1740 -- case of a single protected declaration, since this is the proper 1741 -- scope to be used. 1742 1743 Ref_Id : Entity_Id; 1744 -- This is the entity of the protected object or protected type 1745 -- involved, and is the entity used for cross-reference purposes (it 1746 -- differs from Spec_Id in the case of a single protected object, since 1747 -- Spec_Id is set to the protected type in this case). 1748 1749 function Lock_Free_Disabled return Boolean; 1750 -- This routine returns False if the protected object has a Lock_Free 1751 -- aspect specification or a Lock_Free pragma that turns off the 1752 -- lock-free implementation (e.g. whose expression is False). 1753 1754 ------------------------ 1755 -- Lock_Free_Disabled -- 1756 ------------------------ 1757 1758 function Lock_Free_Disabled return Boolean is 1759 Ritem : constant Node_Id := 1760 Get_Rep_Item 1761 (Spec_Id, Name_Lock_Free, Check_Parents => False); 1762 1763 begin 1764 if Present (Ritem) then 1765 1766 -- Pragma with one argument 1767 1768 if Nkind (Ritem) = N_Pragma 1769 and then Present (Pragma_Argument_Associations (Ritem)) 1770 then 1771 return 1772 Is_False 1773 (Static_Boolean 1774 (Expression 1775 (First (Pragma_Argument_Associations (Ritem))))); 1776 1777 -- Aspect Specification with expression present 1778 1779 elsif Nkind (Ritem) = N_Aspect_Specification 1780 and then Present (Expression (Ritem)) 1781 then 1782 return Is_False (Static_Boolean (Expression (Ritem))); 1783 1784 -- Otherwise, return False 1785 1786 else 1787 return False; 1788 end if; 1789 end if; 1790 1791 return False; 1792 end Lock_Free_Disabled; 1793 1794 -- Start of processing for Analyze_Protected_Body 1795 1796 begin 1797 -- A protected body freezes the contract of the nearest enclosing 1798 -- package body and all other contracts encountered in the same 1799 -- declarative part up to and excluding the protected body. This 1800 -- ensures that any annotations referenced by the contract of an 1801 -- entry or subprogram body declared within the current protected 1802 -- body are available. 1803 1804 Freeze_Previous_Contracts (N); 1805 1806 Tasking_Used := True; 1807 Set_Ekind (Body_Id, E_Protected_Body); 1808 Set_Etype (Body_Id, Standard_Void_Type); 1809 Spec_Id := Find_Concurrent_Spec (Body_Id); 1810 1811 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then 1812 null; 1813 1814 elsif Present (Spec_Id) 1815 and then Ekind (Etype (Spec_Id)) = E_Protected_Type 1816 and then not Comes_From_Source (Etype (Spec_Id)) 1817 then 1818 null; 1819 1820 else 1821 Error_Msg_N ("missing specification for protected body", Body_Id); 1822 return; 1823 end if; 1824 1825 Ref_Id := Spec_Id; 1826 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); 1827 Style.Check_Identifier (Body_Id, Spec_Id); 1828 1829 -- The declarations are always attached to the type 1830 1831 if Ekind (Spec_Id) /= E_Protected_Type then 1832 Spec_Id := Etype (Spec_Id); 1833 end if; 1834 1835 if Has_Aspects (N) then 1836 Analyze_Aspect_Specifications (N, Body_Id); 1837 end if; 1838 1839 Push_Scope (Spec_Id); 1840 Set_Corresponding_Spec (N, Spec_Id); 1841 Set_Corresponding_Body (Parent (Spec_Id), Body_Id); 1842 Set_Has_Completion (Spec_Id); 1843 Install_Declarations (Spec_Id); 1844 Expand_Protected_Body_Declarations (N, Spec_Id); 1845 Last_E := Last_Entity (Spec_Id); 1846 1847 Analyze_Declarations (Declarations (N)); 1848 1849 -- For visibility purposes, all entities in the body are private. Set 1850 -- First_Private_Entity accordingly, if there was no private part in the 1851 -- protected declaration. 1852 1853 if No (First_Private_Entity (Spec_Id)) then 1854 if Present (Last_E) then 1855 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); 1856 else 1857 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); 1858 end if; 1859 end if; 1860 1861 Check_Completion (Body_Id); 1862 Check_References (Spec_Id); 1863 Process_End_Label (N, 't', Ref_Id); 1864 Update_Use_Clause_Chain; 1865 End_Scope; 1866 1867 -- When a Lock_Free aspect specification/pragma forces the lock-free 1868 -- implementation, verify the protected body meets all the restrictions, 1869 -- otherwise Allows_Lock_Free_Implementation issues an error message. 1870 1871 if Uses_Lock_Free (Spec_Id) then 1872 if not Allows_Lock_Free_Implementation (N, True) then 1873 return; 1874 end if; 1875 1876 -- In other cases, if there is no aspect specification/pragma that 1877 -- disables the lock-free implementation, check both the protected 1878 -- declaration and body satisfy the lock-free restrictions. 1879 1880 elsif not Lock_Free_Disabled 1881 and then Allows_Lock_Free_Implementation (Parent (Spec_Id)) 1882 and then Allows_Lock_Free_Implementation (N) 1883 then 1884 Set_Uses_Lock_Free (Spec_Id); 1885 end if; 1886 end Analyze_Protected_Body; 1887 1888 ---------------------------------- 1889 -- Analyze_Protected_Definition -- 1890 ---------------------------------- 1891 1892 procedure Analyze_Protected_Definition (N : Node_Id) is 1893 E : Entity_Id; 1894 L : Entity_Id; 1895 1896 procedure Undelay_Itypes (T : Entity_Id); 1897 -- Itypes created for the private components of a protected type 1898 -- do not receive freeze nodes, because there is no scope in which 1899 -- they can be elaborated, and they can depend on discriminants of 1900 -- the enclosed protected type. Given that the components can be 1901 -- composite types with inner components, we traverse recursively 1902 -- the private components of the protected type, and indicate that 1903 -- all itypes within are frozen. This ensures that no freeze nodes 1904 -- will be generated for them. In the case of itypes that are access 1905 -- types we need to complete their representation by calling layout, 1906 -- which would otherwise be invoked when freezing a type. 1907 -- 1908 -- On the other hand, components of the corresponding record are 1909 -- frozen (or receive itype references) as for other records. 1910 1911 -------------------- 1912 -- Undelay_Itypes -- 1913 -------------------- 1914 1915 procedure Undelay_Itypes (T : Entity_Id) is 1916 Comp : Entity_Id; 1917 1918 begin 1919 if Is_Protected_Type (T) then 1920 Comp := First_Private_Entity (T); 1921 elsif Is_Record_Type (T) then 1922 Comp := First_Entity (T); 1923 else 1924 return; 1925 end if; 1926 1927 while Present (Comp) loop 1928 if Is_Type (Comp) 1929 and then Is_Itype (Comp) 1930 then 1931 Set_Has_Delayed_Freeze (Comp, False); 1932 Set_Is_Frozen (Comp); 1933 1934 if Is_Access_Type (Comp) then 1935 Layout_Type (Comp); 1936 end if; 1937 1938 if Is_Record_Type (Comp) 1939 or else Is_Protected_Type (Comp) 1940 then 1941 Undelay_Itypes (Comp); 1942 end if; 1943 end if; 1944 1945 Next_Entity (Comp); 1946 end loop; 1947 end Undelay_Itypes; 1948 1949 -- Start of processing for Analyze_Protected_Definition 1950 1951 begin 1952 Tasking_Used := True; 1953 Check_SPARK_05_Restriction ("protected definition is not allowed", N); 1954 Analyze_Declarations (Visible_Declarations (N)); 1955 1956 if Present (Private_Declarations (N)) 1957 and then not Is_Empty_List (Private_Declarations (N)) 1958 then 1959 L := Last_Entity (Current_Scope); 1960 Analyze_Declarations (Private_Declarations (N)); 1961 1962 if Present (L) then 1963 Set_First_Private_Entity (Current_Scope, Next_Entity (L)); 1964 else 1965 Set_First_Private_Entity (Current_Scope, 1966 First_Entity (Current_Scope)); 1967 end if; 1968 end if; 1969 1970 E := First_Entity (Current_Scope); 1971 while Present (E) loop 1972 if Ekind_In (E, E_Function, E_Procedure) then 1973 Set_Convention (E, Convention_Protected); 1974 else 1975 Propagate_Concurrent_Flags (Current_Scope, Etype (E)); 1976 end if; 1977 1978 Next_Entity (E); 1979 end loop; 1980 1981 Undelay_Itypes (Current_Scope); 1982 1983 Check_Max_Entries (N, Max_Protected_Entries); 1984 Process_End_Label (N, 'e', Current_Scope); 1985 end Analyze_Protected_Definition; 1986 1987 ---------------------------------------- 1988 -- Analyze_Protected_Type_Declaration -- 1989 ---------------------------------------- 1990 1991 procedure Analyze_Protected_Type_Declaration (N : Node_Id) is 1992 Def_Id : constant Entity_Id := Defining_Identifier (N); 1993 E : Entity_Id; 1994 T : Entity_Id; 1995 1996 begin 1997 if No_Run_Time_Mode then 1998 Error_Msg_CRT ("protected type", N); 1999 2000 if Has_Aspects (N) then 2001 Analyze_Aspect_Specifications (N, Def_Id); 2002 end if; 2003 2004 return; 2005 end if; 2006 2007 Tasking_Used := True; 2008 Check_Restriction (No_Protected_Types, N); 2009 2010 T := Find_Type_Name (N); 2011 2012 -- In the case of an incomplete type, use the full view, unless it's not 2013 -- present (as can occur for an incomplete view from a limited with). 2014 2015 if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then 2016 T := Full_View (T); 2017 Set_Completion_Referenced (T); 2018 end if; 2019 2020 Set_Ekind (T, E_Protected_Type); 2021 Set_Is_First_Subtype (T); 2022 Init_Size_Align (T); 2023 Set_Etype (T, T); 2024 Set_Has_Delayed_Freeze (T); 2025 Set_Stored_Constraint (T, No_Elist); 2026 2027 -- Mark this type as a protected type for the sake of restrictions, 2028 -- unless the protected type is declared in a private part of a package 2029 -- of the runtime. With this exception, the Suspension_Object from 2030 -- Ada.Synchronous_Task_Control can be implemented using a protected 2031 -- object without triggering violations of No_Local_Protected_Objects 2032 -- when the user locally declares such an object. This may look like a 2033 -- trick, but the user doesn't have to know how Suspension_Object is 2034 -- implemented. 2035 2036 if In_Private_Part (Current_Scope) 2037 and then Is_Internal_Unit (Current_Sem_Unit) 2038 then 2039 Set_Has_Protected (T, False); 2040 else 2041 Set_Has_Protected (T); 2042 end if; 2043 2044 -- Set the SPARK_Mode from the current context (may be overwritten later 2045 -- with an explicit pragma). 2046 2047 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 2048 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); 2049 Set_SPARK_Pragma_Inherited (T); 2050 Set_SPARK_Aux_Pragma_Inherited (T); 2051 2052 Push_Scope (T); 2053 2054 if Ada_Version >= Ada_2005 then 2055 Check_Interfaces (N, T); 2056 end if; 2057 2058 if Present (Discriminant_Specifications (N)) then 2059 if Has_Discriminants (T) then 2060 2061 -- Install discriminants. Also, verify conformance of 2062 -- discriminants of previous and current view. ??? 2063 2064 Install_Declarations (T); 2065 else 2066 Process_Discriminants (N); 2067 end if; 2068 end if; 2069 2070 Set_Is_Constrained (T, not Has_Discriminants (T)); 2071 2072 -- If aspects are present, analyze them now. They can make references to 2073 -- the discriminants of the type, but not to any components. 2074 2075 if Has_Aspects (N) then 2076 2077 -- The protected type is the full view of a private type. Analyze the 2078 -- aspects with the entity of the private type to ensure that after 2079 -- both views are exchanged, the aspect are actually associated with 2080 -- the full view. 2081 2082 if T /= Def_Id and then Is_Private_Type (Def_Id) then 2083 Analyze_Aspect_Specifications (N, T); 2084 else 2085 Analyze_Aspect_Specifications (N, Def_Id); 2086 end if; 2087 end if; 2088 2089 Analyze (Protected_Definition (N)); 2090 2091 -- In the case where the protected type is declared at a nested level 2092 -- and the No_Local_Protected_Objects restriction applies, issue a 2093 -- warning that objects of the type will violate the restriction. 2094 2095 if Restriction_Check_Required (No_Local_Protected_Objects) 2096 and then not Is_Library_Level_Entity (T) 2097 and then Comes_From_Source (T) 2098 then 2099 Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); 2100 2101 if Error_Msg_Sloc = No_Location then 2102 Error_Msg_N 2103 ("objects of this type will violate " & 2104 "`No_Local_Protected_Objects`??", N); 2105 else 2106 Error_Msg_N 2107 ("objects of this type will violate " & 2108 "`No_Local_Protected_Objects`#??", N); 2109 end if; 2110 end if; 2111 2112 -- Protected types with entries are controlled (because of the 2113 -- Protection component if nothing else), same for any protected type 2114 -- with interrupt handlers. Note that we need to analyze the protected 2115 -- definition to set Has_Entries and such. 2116 2117 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False 2118 or else Number_Entries (T) > 1) 2119 and then not Restricted_Profile 2120 and then 2121 (Has_Entries (T) 2122 or else Has_Interrupt_Handler (T) 2123 or else Has_Attach_Handler (T)) 2124 then 2125 Set_Has_Controlled_Component (T, True); 2126 end if; 2127 2128 -- The Ekind of components is E_Void during analysis to detect illegal 2129 -- uses. Now it can be set correctly. 2130 2131 E := First_Entity (Current_Scope); 2132 while Present (E) loop 2133 if Ekind (E) = E_Void then 2134 Set_Ekind (E, E_Component); 2135 Init_Component_Location (E); 2136 end if; 2137 2138 Next_Entity (E); 2139 end loop; 2140 2141 End_Scope; 2142 2143 -- When a Lock_Free aspect forces the lock-free implementation, check N 2144 -- meets all the lock-free restrictions. Otherwise, an error message is 2145 -- issued by Allows_Lock_Free_Implementation. 2146 2147 if Uses_Lock_Free (Defining_Identifier (N)) then 2148 2149 -- Complain when there is an explicit aspect/pragma Priority (or 2150 -- Interrupt_Priority) while the lock-free implementation is forced 2151 -- by an aspect/pragma. 2152 2153 declare 2154 Id : constant Entity_Id := Defining_Identifier (Original_Node (N)); 2155 -- The warning must be issued on the original identifier in order 2156 -- to deal properly with the case of a single protected object. 2157 2158 Prio_Item : constant Node_Id := 2159 Get_Rep_Item (Def_Id, Name_Priority, False); 2160 2161 begin 2162 if Present (Prio_Item) then 2163 2164 -- Aspect case 2165 2166 if Nkind (Prio_Item) = N_Aspect_Specification 2167 or else From_Aspect_Specification (Prio_Item) 2168 then 2169 Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); 2170 Error_Msg_NE 2171 ("aspect% for & has no effect when Lock_Free given??", 2172 Prio_Item, Id); 2173 2174 -- Pragma case 2175 2176 else 2177 Error_Msg_Name_1 := Pragma_Name (Prio_Item); 2178 Error_Msg_NE 2179 ("pragma% for & has no effect when Lock_Free given??", 2180 Prio_Item, Id); 2181 end if; 2182 end if; 2183 end; 2184 2185 if not Allows_Lock_Free_Implementation (N, Lock_Free_Given => True) 2186 then 2187 return; 2188 end if; 2189 end if; 2190 2191 -- If the Attach_Handler aspect is specified or the Interrupt_Handler 2192 -- aspect is True, then the initial ceiling priority must be in the 2193 -- range of System.Interrupt_Priority. It is therefore recommanded 2194 -- to use the Interrupt_Priority aspect instead of the Priority aspect. 2195 2196 if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then 2197 declare 2198 Prio_Item : constant Node_Id := 2199 Get_Rep_Item (Def_Id, Name_Priority, False); 2200 2201 begin 2202 if Present (Prio_Item) then 2203 2204 -- Aspect case 2205 2206 if (Nkind (Prio_Item) = N_Aspect_Specification 2207 or else From_Aspect_Specification (Prio_Item)) 2208 and then Chars (Identifier (Prio_Item)) = Name_Priority 2209 then 2210 Error_Msg_N 2211 ("aspect Interrupt_Priority is preferred in presence of " 2212 & "handlers??", Prio_Item); 2213 2214 -- Pragma case 2215 2216 elsif Nkind (Prio_Item) = N_Pragma 2217 and then Pragma_Name (Prio_Item) = Name_Priority 2218 then 2219 Error_Msg_N 2220 ("pragma Interrupt_Priority is preferred in presence of " 2221 & "handlers??", Prio_Item); 2222 end if; 2223 end if; 2224 end; 2225 end if; 2226 2227 -- Case of a completion of a private declaration 2228 2229 if T /= Def_Id and then Is_Private_Type (Def_Id) then 2230 2231 -- Deal with preelaborable initialization. Note that this processing 2232 -- is done by Process_Full_View, but as can be seen below, in this 2233 -- case the call to Process_Full_View is skipped if any serious 2234 -- errors have occurred, and we don't want to lose this check. 2235 2236 if Known_To_Have_Preelab_Init (Def_Id) then 2237 Set_Must_Have_Preelab_Init (T); 2238 end if; 2239 2240 -- Propagate Default_Initial_Condition-related attributes from the 2241 -- private type to the protected type. 2242 2243 Propagate_DIC_Attributes (T, From_Typ => Def_Id); 2244 2245 -- Propagate invariant-related attributes from the private type to 2246 -- the protected type. 2247 2248 Propagate_Invariant_Attributes (T, From_Typ => Def_Id); 2249 2250 -- Create corresponding record now, because some private dependents 2251 -- may be subtypes of the partial view. 2252 2253 -- Skip if errors are present, to prevent cascaded messages 2254 2255 if Serious_Errors_Detected = 0 2256 2257 -- Also skip if expander is not active 2258 2259 and then Expander_Active 2260 then 2261 Expand_N_Protected_Type_Declaration (N); 2262 Process_Full_View (N, T, Def_Id); 2263 end if; 2264 end if; 2265 2266 -- In GNATprove mode, force the loading of a Interrupt_Priority, which 2267 -- is required for the ceiling priority protocol checks triggered by 2268 -- calls originating from protected subprograms and entries. 2269 2270 if GNATprove_Mode then 2271 SPARK_Implicit_Load (RE_Interrupt_Priority); 2272 end if; 2273 end Analyze_Protected_Type_Declaration; 2274 2275 --------------------- 2276 -- Analyze_Requeue -- 2277 --------------------- 2278 2279 procedure Analyze_Requeue (N : Node_Id) is 2280 Count : Natural := 0; 2281 Entry_Name : Node_Id := Name (N); 2282 Entry_Id : Entity_Id; 2283 I : Interp_Index; 2284 Is_Disp_Req : Boolean; 2285 It : Interp; 2286 Enclosing : Entity_Id; 2287 Target_Obj : Node_Id := Empty; 2288 Req_Scope : Entity_Id; 2289 Outer_Ent : Entity_Id; 2290 Synch_Type : Entity_Id := Empty; 2291 2292 begin 2293 -- Preserve relevant elaboration-related attributes of the context which 2294 -- are no longer available or very expensive to recompute once analysis, 2295 -- resolution, and expansion are over. 2296 2297 Mark_Elaboration_Attributes 2298 (N_Id => N, 2299 Checks => True, 2300 Modes => True, 2301 Warnings => True); 2302 2303 Tasking_Used := True; 2304 Check_SPARK_05_Restriction ("requeue statement is not allowed", N); 2305 Check_Restriction (No_Requeue_Statements, N); 2306 Check_Unreachable_Code (N); 2307 2308 Enclosing := Empty; 2309 for J in reverse 0 .. Scope_Stack.Last loop 2310 Enclosing := Scope_Stack.Table (J).Entity; 2311 exit when Is_Entry (Enclosing); 2312 2313 if not Ekind_In (Enclosing, E_Block, E_Loop) then 2314 Error_Msg_N ("requeue must appear within accept or entry body", N); 2315 return; 2316 end if; 2317 end loop; 2318 2319 Analyze (Entry_Name); 2320 2321 if Etype (Entry_Name) = Any_Type then 2322 return; 2323 end if; 2324 2325 if Nkind (Entry_Name) = N_Selected_Component then 2326 Target_Obj := Prefix (Entry_Name); 2327 Entry_Name := Selector_Name (Entry_Name); 2328 end if; 2329 2330 -- If an explicit target object is given then we have to check the 2331 -- restrictions of 9.5.4(6). 2332 2333 if Present (Target_Obj) then 2334 2335 -- Locate containing concurrent unit and determine enclosing entry 2336 -- body or outermost enclosing accept statement within the unit. 2337 2338 Outer_Ent := Empty; 2339 for S in reverse 0 .. Scope_Stack.Last loop 2340 Req_Scope := Scope_Stack.Table (S).Entity; 2341 2342 exit when Ekind (Req_Scope) in Task_Kind 2343 or else Ekind (Req_Scope) in Protected_Kind; 2344 2345 if Is_Entry (Req_Scope) then 2346 Outer_Ent := Req_Scope; 2347 end if; 2348 end loop; 2349 2350 pragma Assert (Present (Outer_Ent)); 2351 2352 -- Check that the accessibility level of the target object is not 2353 -- greater or equal to the outermost enclosing accept statement (or 2354 -- entry body) unless it is a parameter of the innermost enclosing 2355 -- accept statement (or entry body). 2356 2357 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) 2358 and then 2359 (not Is_Entity_Name (Target_Obj) 2360 or else Ekind (Entity (Target_Obj)) not in Formal_Kind 2361 or else Enclosing /= Scope (Entity (Target_Obj))) 2362 then 2363 Error_Msg_N 2364 ("target object has invalid level for requeue", Target_Obj); 2365 end if; 2366 end if; 2367 2368 -- Overloaded case, find right interpretation 2369 2370 if Is_Overloaded (Entry_Name) then 2371 Entry_Id := Empty; 2372 2373 -- Loop over candidate interpretations and filter out any that are 2374 -- not parameterless, are not type conformant, are not entries, or 2375 -- do not come from source. 2376 2377 Get_First_Interp (Entry_Name, I, It); 2378 while Present (It.Nam) loop 2379 2380 -- Note: we test type conformance here, not subtype conformance. 2381 -- Subtype conformance will be tested later on, but it is better 2382 -- for error output in some cases not to do that here. 2383 2384 if (No (First_Formal (It.Nam)) 2385 or else (Type_Conformant (Enclosing, It.Nam))) 2386 and then Ekind (It.Nam) = E_Entry 2387 then 2388 -- Ada 2005 (AI-345): Since protected and task types have 2389 -- primitive entry wrappers, we only consider source entries. 2390 2391 if Comes_From_Source (It.Nam) then 2392 Count := Count + 1; 2393 Entry_Id := It.Nam; 2394 else 2395 Remove_Interp (I); 2396 end if; 2397 end if; 2398 2399 Get_Next_Interp (I, It); 2400 end loop; 2401 2402 if Count = 0 then 2403 Error_Msg_N ("no entry matches context", N); 2404 return; 2405 2406 elsif Count > 1 then 2407 Error_Msg_N ("ambiguous entry name in requeue", N); 2408 return; 2409 2410 else 2411 Set_Is_Overloaded (Entry_Name, False); 2412 Set_Entity (Entry_Name, Entry_Id); 2413 end if; 2414 2415 -- Non-overloaded cases 2416 2417 -- For the case of a reference to an element of an entry family, the 2418 -- Entry_Name is an indexed component. 2419 2420 elsif Nkind (Entry_Name) = N_Indexed_Component then 2421 2422 -- Requeue to an entry out of the body 2423 2424 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then 2425 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name))); 2426 2427 -- Requeue from within the body itself 2428 2429 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then 2430 Entry_Id := Entity (Prefix (Entry_Name)); 2431 2432 else 2433 Error_Msg_N ("invalid entry_name specified", N); 2434 return; 2435 end if; 2436 2437 -- If we had a requeue of the form REQUEUE A (B), then the parser 2438 -- accepted it (because it could have been a requeue on an entry index. 2439 -- If A turns out not to be an entry family, then the analysis of A (B) 2440 -- turned it into a function call. 2441 2442 elsif Nkind (Entry_Name) = N_Function_Call then 2443 Error_Msg_N 2444 ("arguments not allowed in requeue statement", 2445 First (Parameter_Associations (Entry_Name))); 2446 return; 2447 2448 -- Normal case of no entry family, no argument 2449 2450 else 2451 Entry_Id := Entity (Entry_Name); 2452 end if; 2453 2454 -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The 2455 -- target type must be a concurrent interface class-wide type and the 2456 -- target must be a procedure, flagged by pragma Implemented. The 2457 -- target may be an access to class-wide type, in which case it must 2458 -- be dereferenced. 2459 2460 if Present (Target_Obj) then 2461 Synch_Type := Etype (Target_Obj); 2462 2463 if Is_Access_Type (Synch_Type) then 2464 Synch_Type := Designated_Type (Synch_Type); 2465 end if; 2466 end if; 2467 2468 Is_Disp_Req := 2469 Ada_Version >= Ada_2012 2470 and then Present (Target_Obj) 2471 and then Is_Class_Wide_Type (Synch_Type) 2472 and then Is_Concurrent_Interface (Synch_Type) 2473 and then Ekind (Entry_Id) = E_Procedure 2474 and then Has_Rep_Pragma (Entry_Id, Name_Implemented); 2475 2476 -- Resolve entry, and check that it is subtype conformant with the 2477 -- enclosing construct if this construct has formals (RM 9.5.4(5)). 2478 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case. 2479 2480 if not Is_Entry (Entry_Id) 2481 and then not Is_Disp_Req 2482 then 2483 Error_Msg_N ("expect entry name in requeue statement", Name (N)); 2484 2485 elsif Ekind (Entry_Id) = E_Entry_Family 2486 and then Nkind (Entry_Name) /= N_Indexed_Component 2487 then 2488 Error_Msg_N ("missing index for entry family component", Name (N)); 2489 2490 else 2491 Resolve_Entry (Name (N)); 2492 Generate_Reference (Entry_Id, Entry_Name); 2493 2494 if Present (First_Formal (Entry_Id)) then 2495 2496 -- Ada 2012 (AI05-0030): Perform type conformance after skipping 2497 -- the first parameter of Entry_Id since it is the interface 2498 -- controlling formal. 2499 2500 if Ada_Version >= Ada_2012 and then Is_Disp_Req then 2501 declare 2502 Enclosing_Formal : Entity_Id; 2503 Target_Formal : Entity_Id; 2504 2505 begin 2506 Enclosing_Formal := First_Formal (Enclosing); 2507 Target_Formal := Next_Formal (First_Formal (Entry_Id)); 2508 while Present (Enclosing_Formal) 2509 and then Present (Target_Formal) 2510 loop 2511 if not Conforming_Types 2512 (T1 => Etype (Enclosing_Formal), 2513 T2 => Etype (Target_Formal), 2514 Ctype => Subtype_Conformant) 2515 then 2516 Error_Msg_Node_2 := Target_Formal; 2517 Error_Msg_NE 2518 ("formal & is not subtype conformant with &" & 2519 "in dispatching requeue", N, Enclosing_Formal); 2520 end if; 2521 2522 Next_Formal (Enclosing_Formal); 2523 Next_Formal (Target_Formal); 2524 end loop; 2525 end; 2526 else 2527 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); 2528 end if; 2529 2530 -- Processing for parameters accessed by the requeue 2531 2532 declare 2533 Ent : Entity_Id; 2534 2535 begin 2536 Ent := First_Formal (Enclosing); 2537 while Present (Ent) loop 2538 2539 -- For OUT or IN OUT parameter, the effect of the requeue is 2540 -- to assign the parameter a value on exit from the requeued 2541 -- body, so we can set it as source assigned. We also clear 2542 -- the Is_True_Constant indication. We do not need to clear 2543 -- Current_Value, since the effect of the requeue is to 2544 -- perform an unconditional goto so that any further 2545 -- references will not occur anyway. 2546 2547 if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then 2548 Set_Never_Set_In_Source (Ent, False); 2549 Set_Is_True_Constant (Ent, False); 2550 end if; 2551 2552 -- For all parameters, the requeue acts as a reference, 2553 -- since the value of the parameter is passed to the new 2554 -- entry, so we want to suppress unreferenced warnings. 2555 2556 Set_Referenced (Ent); 2557 Next_Formal (Ent); 2558 end loop; 2559 end; 2560 end if; 2561 end if; 2562 2563 -- AI05-0225: the target protected object of a requeue must be a 2564 -- variable. This is a binding interpretation that applies to all 2565 -- versions of the language. Note that the subprogram does not have 2566 -- to be a protected operation: it can be an primitive implemented 2567 -- by entry with a formal that is a protected interface. 2568 2569 if Present (Target_Obj) 2570 and then not Is_Variable (Target_Obj) 2571 then 2572 Error_Msg_N 2573 ("target protected object of requeue must be a variable", N); 2574 end if; 2575 2576 -- A requeue statement is treated as a call for purposes of ABE checks 2577 -- and diagnostics. Annotate the tree by creating a call marker in case 2578 -- the requeue statement is transformed by expansion. 2579 2580 Build_Call_Marker (N); 2581 end Analyze_Requeue; 2582 2583 ------------------------------ 2584 -- Analyze_Selective_Accept -- 2585 ------------------------------ 2586 2587 procedure Analyze_Selective_Accept (N : Node_Id) is 2588 Alts : constant List_Id := Select_Alternatives (N); 2589 Alt : Node_Id; 2590 2591 Accept_Present : Boolean := False; 2592 Terminate_Present : Boolean := False; 2593 Delay_Present : Boolean := False; 2594 Relative_Present : Boolean := False; 2595 Alt_Count : Uint := Uint_0; 2596 2597 begin 2598 Tasking_Used := True; 2599 Check_SPARK_05_Restriction ("select statement is not allowed", N); 2600 Check_Restriction (No_Select_Statements, N); 2601 2602 -- Loop to analyze alternatives 2603 2604 Alt := First (Alts); 2605 while Present (Alt) loop 2606 Alt_Count := Alt_Count + 1; 2607 Analyze (Alt); 2608 2609 if Nkind (Alt) = N_Delay_Alternative then 2610 if Delay_Present then 2611 2612 if Relative_Present /= 2613 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement) 2614 then 2615 Error_Msg_N 2616 ("delay_until and delay_relative alternatives ", Alt); 2617 Error_Msg_N 2618 ("\cannot appear in the same selective_wait", Alt); 2619 end if; 2620 2621 else 2622 Delay_Present := True; 2623 Relative_Present := 2624 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement; 2625 end if; 2626 2627 elsif Nkind (Alt) = N_Terminate_Alternative then 2628 if Terminate_Present then 2629 Error_Msg_N ("only one terminate alternative allowed", N); 2630 else 2631 Terminate_Present := True; 2632 Check_Restriction (No_Terminate_Alternatives, N); 2633 end if; 2634 2635 elsif Nkind (Alt) = N_Accept_Alternative then 2636 Accept_Present := True; 2637 2638 -- Check for duplicate accept 2639 2640 declare 2641 Alt1 : Node_Id; 2642 Stm : constant Node_Id := Accept_Statement (Alt); 2643 EDN : constant Node_Id := Entry_Direct_Name (Stm); 2644 Ent : Entity_Id; 2645 2646 begin 2647 if Nkind (EDN) = N_Identifier 2648 and then No (Condition (Alt)) 2649 and then Present (Entity (EDN)) -- defend against junk 2650 and then Ekind (Entity (EDN)) = E_Entry 2651 then 2652 Ent := Entity (EDN); 2653 2654 Alt1 := First (Alts); 2655 while Alt1 /= Alt loop 2656 if Nkind (Alt1) = N_Accept_Alternative 2657 and then No (Condition (Alt1)) 2658 then 2659 declare 2660 Stm1 : constant Node_Id := Accept_Statement (Alt1); 2661 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1); 2662 2663 begin 2664 if Nkind (EDN1) = N_Identifier then 2665 if Entity (EDN1) = Ent then 2666 Error_Msg_Sloc := Sloc (Stm1); 2667 Error_Msg_N 2668 ("accept duplicates one on line#??", Stm); 2669 exit; 2670 end if; 2671 end if; 2672 end; 2673 end if; 2674 2675 Next (Alt1); 2676 end loop; 2677 end if; 2678 end; 2679 end if; 2680 2681 Next (Alt); 2682 end loop; 2683 2684 Check_Restriction (Max_Select_Alternatives, N, Alt_Count); 2685 Check_Potentially_Blocking_Operation (N); 2686 2687 if Terminate_Present and Delay_Present then 2688 Error_Msg_N ("at most one of terminate or delay alternative", N); 2689 2690 elsif not Accept_Present then 2691 Error_Msg_N 2692 ("select must contain at least one accept alternative", N); 2693 end if; 2694 2695 if Present (Else_Statements (N)) then 2696 if Terminate_Present or Delay_Present then 2697 Error_Msg_N ("else part not allowed with other alternatives", N); 2698 end if; 2699 2700 Analyze_Statements (Else_Statements (N)); 2701 end if; 2702 end Analyze_Selective_Accept; 2703 2704 ------------------------------------------ 2705 -- Analyze_Single_Protected_Declaration -- 2706 ------------------------------------------ 2707 2708 procedure Analyze_Single_Protected_Declaration (N : Node_Id) is 2709 Loc : constant Source_Ptr := Sloc (N); 2710 Obj_Id : constant Node_Id := Defining_Identifier (N); 2711 Obj_Decl : Node_Id; 2712 Typ : Entity_Id; 2713 2714 begin 2715 Generate_Definition (Obj_Id); 2716 Tasking_Used := True; 2717 2718 -- A single protected declaration is transformed into a pair of an 2719 -- anonymous protected type and an object of that type. Generate: 2720 2721 -- protected type Typ is ...; 2722 2723 Typ := 2724 Make_Defining_Identifier (Sloc (Obj_Id), 2725 Chars => New_External_Name (Chars (Obj_Id), 'T')); 2726 2727 Rewrite (N, 2728 Make_Protected_Type_Declaration (Loc, 2729 Defining_Identifier => Typ, 2730 Protected_Definition => Relocate_Node (Protected_Definition (N)), 2731 Interface_List => Interface_List (N))); 2732 2733 -- Use the original defining identifier of the single protected 2734 -- declaration in the generated object declaration to allow for debug 2735 -- information to be attached to it when compiling with -gnatD. The 2736 -- parent of the entity is the new object declaration. The single 2737 -- protected declaration is not used in semantics or code generation, 2738 -- but is scanned when generating debug information, and therefore needs 2739 -- the updated Sloc information from the entity (see Sprint). Generate: 2740 2741 -- Obj : Typ; 2742 2743 Obj_Decl := 2744 Make_Object_Declaration (Loc, 2745 Defining_Identifier => Obj_Id, 2746 Object_Definition => New_Occurrence_Of (Typ, Loc)); 2747 2748 Insert_After (N, Obj_Decl); 2749 Mark_Rewrite_Insertion (Obj_Decl); 2750 2751 -- Relocate aspect Part_Of from the the original single protected 2752 -- declaration to the anonymous object declaration. This emulates the 2753 -- placement of an equivalent source pragma. 2754 2755 Move_Or_Merge_Aspects (N, To => Obj_Decl); 2756 2757 -- Relocate pragma Part_Of from the visible declarations of the original 2758 -- single protected declaration to the anonymous object declaration. The 2759 -- new placement better reflects the role of the pragma. 2760 2761 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); 2762 2763 -- Enter the names of the anonymous protected type and the object before 2764 -- analysis takes places, because the name of the object may be used in 2765 -- its own body. 2766 2767 Enter_Name (Typ); 2768 Set_Ekind (Typ, E_Protected_Type); 2769 Set_Etype (Typ, Typ); 2770 Set_Anonymous_Object (Typ, Obj_Id); 2771 2772 Enter_Name (Obj_Id); 2773 Set_Ekind (Obj_Id, E_Variable); 2774 Set_Etype (Obj_Id, Typ); 2775 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); 2776 Set_SPARK_Pragma_Inherited (Obj_Id); 2777 2778 -- Instead of calling Analyze on the new node, call the proper analysis 2779 -- procedure directly. Otherwise the node would be expanded twice, with 2780 -- disastrous result. 2781 2782 Analyze_Protected_Type_Declaration (N); 2783 2784 if Has_Aspects (N) then 2785 Analyze_Aspect_Specifications (N, Obj_Id); 2786 end if; 2787 end Analyze_Single_Protected_Declaration; 2788 2789 ------------------------------------- 2790 -- Analyze_Single_Task_Declaration -- 2791 ------------------------------------- 2792 2793 procedure Analyze_Single_Task_Declaration (N : Node_Id) is 2794 Loc : constant Source_Ptr := Sloc (N); 2795 Obj_Id : constant Node_Id := Defining_Identifier (N); 2796 Obj_Decl : Node_Id; 2797 Typ : Entity_Id; 2798 2799 begin 2800 Generate_Definition (Obj_Id); 2801 Tasking_Used := True; 2802 2803 -- A single task declaration is transformed into a pair of an anonymous 2804 -- task type and an object of that type. Generate: 2805 2806 -- task type Typ is ...; 2807 2808 Typ := 2809 Make_Defining_Identifier (Sloc (Obj_Id), 2810 Chars => New_External_Name (Chars (Obj_Id), Suffix => "TK")); 2811 2812 Rewrite (N, 2813 Make_Task_Type_Declaration (Loc, 2814 Defining_Identifier => Typ, 2815 Task_Definition => Relocate_Node (Task_Definition (N)), 2816 Interface_List => Interface_List (N))); 2817 2818 -- Use the original defining identifier of the single task declaration 2819 -- in the generated object declaration to allow for debug information 2820 -- to be attached to it when compiling with -gnatD. The parent of the 2821 -- entity is the new object declaration. The single task declaration 2822 -- is not used in semantics or code generation, but is scanned when 2823 -- generating debug information, and therefore needs the updated Sloc 2824 -- information from the entity (see Sprint). Generate: 2825 2826 -- Obj : Typ; 2827 2828 Obj_Decl := 2829 Make_Object_Declaration (Loc, 2830 Defining_Identifier => Obj_Id, 2831 Object_Definition => New_Occurrence_Of (Typ, Loc)); 2832 2833 Insert_After (N, Obj_Decl); 2834 Mark_Rewrite_Insertion (Obj_Decl); 2835 2836 -- Relocate aspects Depends, Global and Part_Of from the original single 2837 -- task declaration to the anonymous object declaration. This emulates 2838 -- the placement of an equivalent source pragma. 2839 2840 Move_Or_Merge_Aspects (N, To => Obj_Decl); 2841 2842 -- Relocate pragmas Depends, Global and Part_Of from the visible 2843 -- declarations of the original single protected declaration to the 2844 -- anonymous object declaration. The new placement better reflects the 2845 -- role of the pragmas. 2846 2847 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); 2848 2849 -- Enter the names of the anonymous task type and the object before 2850 -- analysis takes places, because the name of the object may be used 2851 -- in its own body. 2852 2853 Enter_Name (Typ); 2854 Set_Ekind (Typ, E_Task_Type); 2855 Set_Etype (Typ, Typ); 2856 Set_Anonymous_Object (Typ, Obj_Id); 2857 2858 Enter_Name (Obj_Id); 2859 Set_Ekind (Obj_Id, E_Variable); 2860 Set_Etype (Obj_Id, Typ); 2861 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); 2862 Set_SPARK_Pragma_Inherited (Obj_Id); 2863 2864 -- Preserve relevant elaboration-related attributes of the context which 2865 -- are no longer available or very expensive to recompute once analysis, 2866 -- resolution, and expansion are over. 2867 2868 Mark_Elaboration_Attributes 2869 (N_Id => Obj_Id, 2870 Checks => True); 2871 2872 -- Instead of calling Analyze on the new node, call the proper analysis 2873 -- procedure directly. Otherwise the node would be expanded twice, with 2874 -- disastrous result. 2875 2876 Analyze_Task_Type_Declaration (N); 2877 2878 if Has_Aspects (N) then 2879 Analyze_Aspect_Specifications (N, Obj_Id); 2880 end if; 2881 end Analyze_Single_Task_Declaration; 2882 2883 ----------------------- 2884 -- Analyze_Task_Body -- 2885 ----------------------- 2886 2887 procedure Analyze_Task_Body (N : Node_Id) is 2888 Body_Id : constant Entity_Id := Defining_Identifier (N); 2889 Decls : constant List_Id := Declarations (N); 2890 HSS : constant Node_Id := Handled_Statement_Sequence (N); 2891 Last_E : Entity_Id; 2892 2893 Spec_Id : Entity_Id; 2894 -- This is initially the entity of the task or task type involved, but 2895 -- is replaced by the task type always in the case of a single task 2896 -- declaration, since this is the proper scope to be used. 2897 2898 Ref_Id : Entity_Id; 2899 -- This is the entity of the task or task type, and is the entity used 2900 -- for cross-reference purposes (it differs from Spec_Id in the case of 2901 -- a single task, since Spec_Id is set to the task type). 2902 2903 begin 2904 -- A task body freezes the contract of the nearest enclosing package 2905 -- body and all other contracts encountered in the same declarative part 2906 -- up to and excluding the task body. This ensures that annotations 2907 -- referenced by the contract of an entry or subprogram body declared 2908 -- within the current protected body are available. 2909 2910 Freeze_Previous_Contracts (N); 2911 2912 Tasking_Used := True; 2913 Set_Scope (Body_Id, Current_Scope); 2914 Set_Ekind (Body_Id, E_Task_Body); 2915 Set_Etype (Body_Id, Standard_Void_Type); 2916 Spec_Id := Find_Concurrent_Spec (Body_Id); 2917 2918 -- The spec is either a task type declaration, or a single task 2919 -- declaration for which we have created an anonymous type. 2920 2921 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Task_Type then 2922 null; 2923 2924 elsif Present (Spec_Id) 2925 and then Ekind (Etype (Spec_Id)) = E_Task_Type 2926 and then not Comes_From_Source (Etype (Spec_Id)) 2927 then 2928 null; 2929 2930 else 2931 Error_Msg_N ("missing specification for task body", Body_Id); 2932 return; 2933 end if; 2934 2935 if Has_Completion (Spec_Id) 2936 and then Present (Corresponding_Body (Parent (Spec_Id))) 2937 then 2938 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then 2939 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id); 2940 else 2941 Error_Msg_NE ("duplicate body for task&", N, Spec_Id); 2942 end if; 2943 end if; 2944 2945 Ref_Id := Spec_Id; 2946 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); 2947 Style.Check_Identifier (Body_Id, Spec_Id); 2948 2949 -- Deal with case of body of single task (anonymous type was created) 2950 2951 if Ekind (Spec_Id) = E_Variable then 2952 Spec_Id := Etype (Spec_Id); 2953 end if; 2954 2955 -- Set the SPARK_Mode from the current context (may be overwritten later 2956 -- with an explicit pragma). 2957 2958 Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); 2959 Set_SPARK_Pragma_Inherited (Body_Id); 2960 2961 if Has_Aspects (N) then 2962 Analyze_Aspect_Specifications (N, Body_Id); 2963 end if; 2964 2965 Push_Scope (Spec_Id); 2966 Set_Corresponding_Spec (N, Spec_Id); 2967 Set_Corresponding_Body (Parent (Spec_Id), Body_Id); 2968 Set_Has_Completion (Spec_Id); 2969 Install_Declarations (Spec_Id); 2970 Last_E := Last_Entity (Spec_Id); 2971 2972 Analyze_Declarations (Decls); 2973 Inspect_Deferred_Constant_Completion (Decls); 2974 2975 -- For visibility purposes, all entities in the body are private. Set 2976 -- First_Private_Entity accordingly, if there was no private part in the 2977 -- protected declaration. 2978 2979 if No (First_Private_Entity (Spec_Id)) then 2980 if Present (Last_E) then 2981 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); 2982 else 2983 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); 2984 end if; 2985 end if; 2986 2987 -- Mark all handlers as not suitable for local raise optimization, 2988 -- since this optimization causes difficulties in a task context. 2989 2990 if Present (Exception_Handlers (HSS)) then 2991 declare 2992 Handlr : Node_Id; 2993 begin 2994 Handlr := First (Exception_Handlers (HSS)); 2995 while Present (Handlr) loop 2996 Set_Local_Raise_Not_OK (Handlr); 2997 Next (Handlr); 2998 end loop; 2999 end; 3000 end if; 3001 3002 -- Now go ahead and complete analysis of the task body 3003 3004 Analyze (HSS); 3005 Check_Completion (Body_Id); 3006 Check_References (Body_Id); 3007 Check_References (Spec_Id); 3008 3009 -- Check for entries with no corresponding accept 3010 3011 declare 3012 Ent : Entity_Id; 3013 3014 begin 3015 Ent := First_Entity (Spec_Id); 3016 while Present (Ent) loop 3017 if Is_Entry (Ent) 3018 and then not Entry_Accepted (Ent) 3019 and then Comes_From_Source (Ent) 3020 then 3021 Error_Msg_NE ("no accept for entry &??", N, Ent); 3022 end if; 3023 3024 Next_Entity (Ent); 3025 end loop; 3026 end; 3027 3028 Process_End_Label (HSS, 't', Ref_Id); 3029 Update_Use_Clause_Chain; 3030 End_Scope; 3031 end Analyze_Task_Body; 3032 3033 ----------------------------- 3034 -- Analyze_Task_Definition -- 3035 ----------------------------- 3036 3037 procedure Analyze_Task_Definition (N : Node_Id) is 3038 L : Entity_Id; 3039 3040 begin 3041 Tasking_Used := True; 3042 Check_SPARK_05_Restriction ("task definition is not allowed", N); 3043 3044 if Present (Visible_Declarations (N)) then 3045 Analyze_Declarations (Visible_Declarations (N)); 3046 end if; 3047 3048 if Present (Private_Declarations (N)) then 3049 L := Last_Entity (Current_Scope); 3050 Analyze_Declarations (Private_Declarations (N)); 3051 3052 if Present (L) then 3053 Set_First_Private_Entity 3054 (Current_Scope, Next_Entity (L)); 3055 else 3056 Set_First_Private_Entity 3057 (Current_Scope, First_Entity (Current_Scope)); 3058 end if; 3059 end if; 3060 3061 Check_Max_Entries (N, Max_Task_Entries); 3062 Process_End_Label (N, 'e', Current_Scope); 3063 end Analyze_Task_Definition; 3064 3065 ----------------------------------- 3066 -- Analyze_Task_Type_Declaration -- 3067 ----------------------------------- 3068 3069 procedure Analyze_Task_Type_Declaration (N : Node_Id) is 3070 Def_Id : constant Entity_Id := Defining_Identifier (N); 3071 T : Entity_Id; 3072 3073 begin 3074 -- Attempt to use tasking in no run time mode is not allowe. Issue hard 3075 -- error message to disable expansion which leads to crashes. 3076 3077 if Opt.No_Run_Time_Mode then 3078 Error_Msg_N ("tasking not allowed in No_Run_Time mode", N); 3079 3080 -- Otherwise soft check for no tasking restriction 3081 3082 else 3083 Check_Restriction (No_Tasking, N); 3084 end if; 3085 3086 -- Proceed ahead with analysis of task type declaration 3087 3088 Tasking_Used := True; 3089 3090 -- The sequential partition elaboration policy is supported only in the 3091 -- restricted profile. 3092 3093 if Partition_Elaboration_Policy = 'S' 3094 and then not Restricted_Profile 3095 then 3096 Error_Msg_N 3097 ("sequential elaboration supported only in restricted profile", N); 3098 end if; 3099 3100 T := Find_Type_Name (N); 3101 Generate_Definition (T); 3102 3103 -- In the case of an incomplete type, use the full view, unless it's not 3104 -- present (as can occur for an incomplete view from a limited with). 3105 -- Initialize the Corresponding_Record_Type (which overlays the Private 3106 -- Dependents field of the incomplete view). 3107 3108 if Ekind (T) = E_Incomplete_Type then 3109 if Present (Full_View (T)) then 3110 T := Full_View (T); 3111 Set_Completion_Referenced (T); 3112 3113 else 3114 Set_Ekind (T, E_Task_Type); 3115 Set_Corresponding_Record_Type (T, Empty); 3116 end if; 3117 end if; 3118 3119 Set_Ekind (T, E_Task_Type); 3120 Set_Is_First_Subtype (T, True); 3121 Set_Has_Task (T, True); 3122 Init_Size_Align (T); 3123 Set_Etype (T, T); 3124 Set_Has_Delayed_Freeze (T, True); 3125 Set_Stored_Constraint (T, No_Elist); 3126 3127 -- Set the SPARK_Mode from the current context (may be overwritten later 3128 -- with an explicit pragma). 3129 3130 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 3131 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); 3132 Set_SPARK_Pragma_Inherited (T); 3133 Set_SPARK_Aux_Pragma_Inherited (T); 3134 3135 -- Preserve relevant elaboration-related attributes of the context which 3136 -- are no longer available or very expensive to recompute once analysis, 3137 -- resolution, and expansion are over. 3138 3139 Mark_Elaboration_Attributes 3140 (N_Id => T, 3141 Checks => True); 3142 3143 Push_Scope (T); 3144 3145 if Ada_Version >= Ada_2005 then 3146 Check_Interfaces (N, T); 3147 end if; 3148 3149 if Present (Discriminant_Specifications (N)) then 3150 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 3151 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); 3152 end if; 3153 3154 if Has_Discriminants (T) then 3155 3156 -- Install discriminants. Also, verify conformance of 3157 -- discriminants of previous and current view. ??? 3158 3159 Install_Declarations (T); 3160 else 3161 Process_Discriminants (N); 3162 end if; 3163 end if; 3164 3165 Set_Is_Constrained (T, not Has_Discriminants (T)); 3166 3167 if Has_Aspects (N) then 3168 3169 -- The task type is the full view of a private type. Analyze the 3170 -- aspects with the entity of the private type to ensure that after 3171 -- both views are exchanged, the aspect are actually associated with 3172 -- the full view. 3173 3174 if T /= Def_Id and then Is_Private_Type (Def_Id) then 3175 Analyze_Aspect_Specifications (N, T); 3176 else 3177 Analyze_Aspect_Specifications (N, Def_Id); 3178 end if; 3179 end if; 3180 3181 if Present (Task_Definition (N)) then 3182 Analyze_Task_Definition (Task_Definition (N)); 3183 end if; 3184 3185 -- In the case where the task type is declared at a nested level and the 3186 -- No_Task_Hierarchy restriction applies, issue a warning that objects 3187 -- of the type will violate the restriction. 3188 3189 if Restriction_Check_Required (No_Task_Hierarchy) 3190 and then not Is_Library_Level_Entity (T) 3191 and then Comes_From_Source (T) 3192 and then not CodePeer_Mode 3193 then 3194 Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); 3195 3196 if Error_Msg_Sloc = No_Location then 3197 Error_Msg_N 3198 ("objects of this type will violate `No_Task_Hierarchy`??", N); 3199 else 3200 Error_Msg_N 3201 ("objects of this type will violate `No_Task_Hierarchy`#??", N); 3202 end if; 3203 end if; 3204 3205 End_Scope; 3206 3207 -- Case of a completion of a private declaration 3208 3209 if T /= Def_Id and then Is_Private_Type (Def_Id) then 3210 3211 -- Deal with preelaborable initialization. Note that this processing 3212 -- is done by Process_Full_View, but as can be seen below, in this 3213 -- case the call to Process_Full_View is skipped if any serious 3214 -- errors have occurred, and we don't want to lose this check. 3215 3216 if Known_To_Have_Preelab_Init (Def_Id) then 3217 Set_Must_Have_Preelab_Init (T); 3218 end if; 3219 3220 -- Propagate Default_Initial_Condition-related attributes from the 3221 -- private type to the task type. 3222 3223 Propagate_DIC_Attributes (T, From_Typ => Def_Id); 3224 3225 -- Propagate invariant-related attributes from the private type to 3226 -- task type. 3227 3228 Propagate_Invariant_Attributes (T, From_Typ => Def_Id); 3229 3230 -- Create corresponding record now, because some private dependents 3231 -- may be subtypes of the partial view. 3232 3233 -- Skip if errors are present, to prevent cascaded messages 3234 3235 if Serious_Errors_Detected = 0 3236 3237 -- Also skip if expander is not active 3238 3239 and then Expander_Active 3240 then 3241 Expand_N_Task_Type_Declaration (N); 3242 Process_Full_View (N, T, Def_Id); 3243 end if; 3244 end if; 3245 3246 -- In GNATprove mode, force the loading of a Interrupt_Priority, which 3247 -- is required for the ceiling priority protocol checks triggered by 3248 -- calls originating from tasks. 3249 3250 if GNATprove_Mode then 3251 SPARK_Implicit_Load (RE_Interrupt_Priority); 3252 end if; 3253 end Analyze_Task_Type_Declaration; 3254 3255 ----------------------------------- 3256 -- Analyze_Terminate_Alternative -- 3257 ----------------------------------- 3258 3259 procedure Analyze_Terminate_Alternative (N : Node_Id) is 3260 begin 3261 Tasking_Used := True; 3262 3263 if Present (Pragmas_Before (N)) then 3264 Analyze_List (Pragmas_Before (N)); 3265 end if; 3266 3267 if Present (Condition (N)) then 3268 Analyze_And_Resolve (Condition (N), Any_Boolean); 3269 end if; 3270 end Analyze_Terminate_Alternative; 3271 3272 ------------------------------ 3273 -- Analyze_Timed_Entry_Call -- 3274 ------------------------------ 3275 3276 procedure Analyze_Timed_Entry_Call (N : Node_Id) is 3277 Trigger : constant Node_Id := 3278 Entry_Call_Statement (Entry_Call_Alternative (N)); 3279 Is_Disp_Select : Boolean := False; 3280 3281 begin 3282 Tasking_Used := True; 3283 Check_SPARK_05_Restriction ("select statement is not allowed", N); 3284 Check_Restriction (No_Select_Statements, N); 3285 3286 -- Ada 2005 (AI-345): The trigger may be a dispatching call 3287 3288 if Ada_Version >= Ada_2005 then 3289 Analyze (Trigger); 3290 Check_Triggering_Statement (Trigger, N, Is_Disp_Select); 3291 end if; 3292 3293 -- Postpone the analysis of the statements till expansion. Analyze only 3294 -- if the expander is disabled in order to catch any semantic errors. 3295 3296 if Is_Disp_Select then 3297 if not Expander_Active then 3298 Analyze (Entry_Call_Alternative (N)); 3299 Analyze (Delay_Alternative (N)); 3300 end if; 3301 3302 -- Regular select analysis 3303 3304 else 3305 Analyze (Entry_Call_Alternative (N)); 3306 Analyze (Delay_Alternative (N)); 3307 end if; 3308 end Analyze_Timed_Entry_Call; 3309 3310 ------------------------------------ 3311 -- Analyze_Triggering_Alternative -- 3312 ------------------------------------ 3313 3314 procedure Analyze_Triggering_Alternative (N : Node_Id) is 3315 Trigger : constant Node_Id := Triggering_Statement (N); 3316 3317 begin 3318 Tasking_Used := True; 3319 3320 if Present (Pragmas_Before (N)) then 3321 Analyze_List (Pragmas_Before (N)); 3322 end if; 3323 3324 Analyze (Trigger); 3325 3326 if Comes_From_Source (Trigger) 3327 and then Nkind (Trigger) not in N_Delay_Statement 3328 and then Nkind (Trigger) /= N_Entry_Call_Statement 3329 then 3330 if Ada_Version < Ada_2005 then 3331 Error_Msg_N 3332 ("triggering statement must be delay or entry call", Trigger); 3333 3334 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a 3335 -- procedure_or_entry_call, the procedure_name or procedure_prefix 3336 -- of the procedure_call_statement shall denote an entry renamed by a 3337 -- procedure, or (a view of) a primitive subprogram of a limited 3338 -- interface whose first parameter is a controlling parameter. 3339 3340 elsif Nkind (Trigger) = N_Procedure_Call_Statement 3341 and then not Is_Renamed_Entry (Entity (Name (Trigger))) 3342 and then not Is_Controlling_Limited_Procedure 3343 (Entity (Name (Trigger))) 3344 then 3345 Error_Msg_N 3346 ("triggering statement must be procedure or entry call " & 3347 "or delay statement", Trigger); 3348 end if; 3349 end if; 3350 3351 if Is_Non_Empty_List (Statements (N)) then 3352 Analyze_Statements (Statements (N)); 3353 end if; 3354 end Analyze_Triggering_Alternative; 3355 3356 ----------------------- 3357 -- Check_Max_Entries -- 3358 ----------------------- 3359 3360 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is 3361 Ecount : Uint; 3362 3363 procedure Count (L : List_Id); 3364 -- Count entries in given declaration list 3365 3366 ----------- 3367 -- Count -- 3368 ----------- 3369 3370 procedure Count (L : List_Id) is 3371 D : Node_Id; 3372 3373 begin 3374 if No (L) then 3375 return; 3376 end if; 3377 3378 D := First (L); 3379 while Present (D) loop 3380 if Nkind (D) = N_Entry_Declaration then 3381 declare 3382 DSD : constant Node_Id := 3383 Discrete_Subtype_Definition (D); 3384 3385 begin 3386 -- If not an entry family, then just one entry 3387 3388 if No (DSD) then 3389 Ecount := Ecount + 1; 3390 3391 -- If entry family with static bounds, count entries 3392 3393 elsif Is_OK_Static_Subtype (Etype (DSD)) then 3394 declare 3395 Lo : constant Uint := 3396 Expr_Value 3397 (Type_Low_Bound (Etype (DSD))); 3398 Hi : constant Uint := 3399 Expr_Value 3400 (Type_High_Bound (Etype (DSD))); 3401 3402 begin 3403 if Hi >= Lo then 3404 Ecount := Ecount + Hi - Lo + 1; 3405 end if; 3406 end; 3407 3408 -- Entry family with non-static bounds 3409 3410 else 3411 -- Record an unknown count restriction, and if the 3412 -- restriction is active, post a message or warning. 3413 3414 Check_Restriction (R, D); 3415 end if; 3416 end; 3417 end if; 3418 3419 Next (D); 3420 end loop; 3421 end Count; 3422 3423 -- Start of processing for Check_Max_Entries 3424 3425 begin 3426 Ecount := Uint_0; 3427 Count (Visible_Declarations (D)); 3428 Count (Private_Declarations (D)); 3429 3430 if Ecount > 0 then 3431 Check_Restriction (R, D, Ecount); 3432 end if; 3433 end Check_Max_Entries; 3434 3435 ---------------------- 3436 -- Check_Interfaces -- 3437 ---------------------- 3438 3439 procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is 3440 Iface : Node_Id; 3441 Iface_Typ : Entity_Id; 3442 3443 begin 3444 pragma Assert 3445 (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration)); 3446 3447 if Present (Interface_List (N)) then 3448 Set_Is_Tagged_Type (T); 3449 3450 -- The primitive operations of a tagged synchronized type are placed 3451 -- on the Corresponding_Record for proper dispatching, but are 3452 -- attached to the synchronized type itself when expansion is 3453 -- disabled, for ASIS use. 3454 3455 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3456 3457 Iface := First (Interface_List (N)); 3458 while Present (Iface) loop 3459 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 3460 3461 if not Is_Interface (Iface_Typ) then 3462 Error_Msg_NE 3463 ("(Ada 2005) & must be an interface", Iface, Iface_Typ); 3464 3465 else 3466 -- Ada 2005 (AI-251): "The declaration of a specific descendant 3467 -- of an interface type freezes the interface type" RM 13.14. 3468 3469 Freeze_Before (N, Etype (Iface)); 3470 3471 if Nkind (N) = N_Protected_Type_Declaration then 3472 3473 -- Ada 2005 (AI-345): Protected types can only implement 3474 -- limited, synchronized, or protected interfaces (note that 3475 -- the predicate Is_Limited_Interface includes synchronized 3476 -- and protected interfaces). 3477 3478 if Is_Task_Interface (Iface_Typ) then 3479 Error_Msg_N ("(Ada 2005) protected type cannot implement " 3480 & "a task interface", Iface); 3481 3482 elsif not Is_Limited_Interface (Iface_Typ) then 3483 Error_Msg_N ("(Ada 2005) protected type cannot implement " 3484 & "a non-limited interface", Iface); 3485 end if; 3486 3487 else pragma Assert (Nkind (N) = N_Task_Type_Declaration); 3488 3489 -- Ada 2005 (AI-345): Task types can only implement limited, 3490 -- synchronized, or task interfaces (note that the predicate 3491 -- Is_Limited_Interface includes synchronized and task 3492 -- interfaces). 3493 3494 if Is_Protected_Interface (Iface_Typ) then 3495 Error_Msg_N ("(Ada 2005) task type cannot implement a " & 3496 "protected interface", Iface); 3497 3498 elsif not Is_Limited_Interface (Iface_Typ) then 3499 Error_Msg_N ("(Ada 2005) task type cannot implement a " & 3500 "non-limited interface", Iface); 3501 end if; 3502 end if; 3503 end if; 3504 3505 Next (Iface); 3506 end loop; 3507 end if; 3508 3509 if not Has_Private_Declaration (T) then 3510 return; 3511 end if; 3512 3513 -- Additional checks on full-types associated with private type 3514 -- declarations. Search for the private type declaration. 3515 3516 declare 3517 Full_T_Ifaces : Elist_Id := No_Elist; 3518 Iface : Node_Id; 3519 Priv_T : Entity_Id; 3520 Priv_T_Ifaces : Elist_Id := No_Elist; 3521 3522 begin 3523 Priv_T := First_Entity (Scope (T)); 3524 loop 3525 pragma Assert (Present (Priv_T)); 3526 3527 if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then 3528 exit when Full_View (Priv_T) = T; 3529 end if; 3530 3531 Next_Entity (Priv_T); 3532 end loop; 3533 3534 -- In case of synchronized types covering interfaces the private type 3535 -- declaration must be limited. 3536 3537 if Present (Interface_List (N)) 3538 and then not Is_Limited_Type (Priv_T) 3539 then 3540 Error_Msg_Sloc := Sloc (Priv_T); 3541 Error_Msg_N ("(Ada 2005) limited type declaration expected for " & 3542 "private type#", T); 3543 end if; 3544 3545 -- RM 7.3 (7.1/2): If the full view has a partial view that is 3546 -- tagged then check RM 7.3 subsidiary rules. 3547 3548 if Is_Tagged_Type (Priv_T) 3549 and then not Error_Posted (N) 3550 then 3551 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged 3552 -- type if and only if the full type is a synchronized tagged type 3553 3554 if Is_Synchronized_Tagged_Type (Priv_T) 3555 and then not Is_Synchronized_Tagged_Type (T) 3556 then 3557 Error_Msg_N 3558 ("(Ada 2005) full view must be a synchronized tagged " & 3559 "type (RM 7.3 (7.2/2))", Priv_T); 3560 3561 elsif Is_Synchronized_Tagged_Type (T) 3562 and then not Is_Synchronized_Tagged_Type (Priv_T) 3563 then 3564 Error_Msg_N 3565 ("(Ada 2005) partial view must be a synchronized tagged " & 3566 "type (RM 7.3 (7.2/2))", T); 3567 end if; 3568 3569 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an 3570 -- interface type if and only if the full type is descendant of 3571 -- the interface type. 3572 3573 if Present (Interface_List (N)) 3574 or else (Is_Tagged_Type (Priv_T) 3575 and then Has_Interfaces 3576 (Priv_T, Use_Full_View => False)) 3577 then 3578 if Is_Tagged_Type (Priv_T) then 3579 Collect_Interfaces 3580 (Priv_T, Priv_T_Ifaces, Use_Full_View => False); 3581 end if; 3582 3583 if Is_Tagged_Type (T) then 3584 Collect_Interfaces (T, Full_T_Ifaces); 3585 end if; 3586 3587 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); 3588 3589 if Present (Iface) then 3590 Error_Msg_NE 3591 ("interface in partial view& not implemented by full " 3592 & "type (RM-2005 7.3 (7.3/2))", T, Iface); 3593 end if; 3594 3595 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); 3596 3597 if Present (Iface) then 3598 Error_Msg_NE 3599 ("interface & not implemented by partial " & 3600 "view (RM-2005 7.3 (7.3/2))", T, Iface); 3601 end if; 3602 end if; 3603 end if; 3604 end; 3605 end Check_Interfaces; 3606 3607 -------------------------------- 3608 -- Check_Triggering_Statement -- 3609 -------------------------------- 3610 3611 procedure Check_Triggering_Statement 3612 (Trigger : Node_Id; 3613 Error_Node : Node_Id; 3614 Is_Dispatching : out Boolean) 3615 is 3616 Param : Node_Id; 3617 3618 begin 3619 Is_Dispatching := False; 3620 3621 -- It is not possible to have a dispatching trigger if we are not in 3622 -- Ada 2005 mode. 3623 3624 if Ada_Version >= Ada_2005 3625 and then Nkind (Trigger) = N_Procedure_Call_Statement 3626 and then Present (Parameter_Associations (Trigger)) 3627 then 3628 Param := First (Parameter_Associations (Trigger)); 3629 3630 if Is_Controlling_Actual (Param) 3631 and then Is_Interface (Etype (Param)) 3632 then 3633 if Is_Limited_Record (Etype (Param)) then 3634 Is_Dispatching := True; 3635 else 3636 Error_Msg_N 3637 ("dispatching operation of limited or synchronized " & 3638 "interface required (RM 9.7.2(3))!", Error_Node); 3639 end if; 3640 3641 elsif Nkind (Trigger) = N_Explicit_Dereference then 3642 Error_Msg_N 3643 ("entry call or dispatching primitive of interface required ", 3644 Trigger); 3645 end if; 3646 end if; 3647 end Check_Triggering_Statement; 3648 3649 -------------------------- 3650 -- Find_Concurrent_Spec -- 3651 -------------------------- 3652 3653 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is 3654 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id); 3655 3656 begin 3657 -- The type may have been given by an incomplete type declaration. 3658 -- Find full view now. 3659 3660 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then 3661 Spec_Id := Full_View (Spec_Id); 3662 end if; 3663 3664 return Spec_Id; 3665 end Find_Concurrent_Spec; 3666 3667 -------------------------- 3668 -- Install_Declarations -- 3669 -------------------------- 3670 3671 procedure Install_Declarations (Spec : Entity_Id) is 3672 E : Entity_Id; 3673 Prev : Entity_Id; 3674 begin 3675 E := First_Entity (Spec); 3676 while Present (E) loop 3677 Prev := Current_Entity (E); 3678 Set_Current_Entity (E); 3679 Set_Is_Immediately_Visible (E); 3680 Set_Homonym (E, Prev); 3681 Next_Entity (E); 3682 end loop; 3683 end Install_Declarations; 3684 3685end Sem_Ch9; 3686