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