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