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-2013, 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 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 -- Protected bodies are currently removed by the expander. Since there 1738 -- are no language-defined aspects that apply to a protected body, it is 1739 -- not worth changing the whole expansion to accomodate implementation- 1740 -- defined aspects. Plus we cannot possibly known the semantics of such 1741 -- future implementation defined aspects in order to plan ahead. 1742 1743 if Has_Aspects (N) then 1744 Error_Msg_N 1745 ("aspects on protected bodies are not allowed", 1746 First (Aspect_Specifications (N))); 1747 1748 -- Remove illegal aspects to prevent cascaded errors later on 1749 1750 Remove_Aspects (N); 1751 end if; 1752 1753 if Present (Spec_Id) 1754 and then Ekind (Spec_Id) = E_Protected_Type 1755 then 1756 null; 1757 1758 elsif Present (Spec_Id) 1759 and then Ekind (Etype (Spec_Id)) = E_Protected_Type 1760 and then not Comes_From_Source (Etype (Spec_Id)) 1761 then 1762 null; 1763 1764 else 1765 Error_Msg_N ("missing specification for protected body", Body_Id); 1766 return; 1767 end if; 1768 1769 Ref_Id := Spec_Id; 1770 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); 1771 Style.Check_Identifier (Body_Id, Spec_Id); 1772 1773 -- The declarations are always attached to the type 1774 1775 if Ekind (Spec_Id) /= E_Protected_Type then 1776 Spec_Id := Etype (Spec_Id); 1777 end if; 1778 1779 Push_Scope (Spec_Id); 1780 Set_Corresponding_Spec (N, Spec_Id); 1781 Set_Corresponding_Body (Parent (Spec_Id), Body_Id); 1782 Set_Has_Completion (Spec_Id); 1783 Install_Declarations (Spec_Id); 1784 1785 Expand_Protected_Body_Declarations (N, Spec_Id); 1786 1787 Last_E := Last_Entity (Spec_Id); 1788 1789 Analyze_Declarations (Declarations (N)); 1790 1791 -- For visibility purposes, all entities in the body are private. Set 1792 -- First_Private_Entity accordingly, if there was no private part in the 1793 -- protected declaration. 1794 1795 if No (First_Private_Entity (Spec_Id)) then 1796 if Present (Last_E) then 1797 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); 1798 else 1799 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); 1800 end if; 1801 end if; 1802 1803 Check_Completion (Body_Id); 1804 Check_References (Spec_Id); 1805 Process_End_Label (N, 't', Ref_Id); 1806 End_Scope; 1807 1808 -- When a Lock_Free aspect specification/pragma forces the lock-free 1809 -- implementation, verify the protected body meets all the restrictions, 1810 -- otherwise Allows_Lock_Free_Implementation issues an error message. 1811 1812 if Uses_Lock_Free (Spec_Id) then 1813 if not Allows_Lock_Free_Implementation (N, True) then 1814 return; 1815 end if; 1816 1817 -- In other cases, if there is no aspect specification/pragma that 1818 -- disables the lock-free implementation, check both the protected 1819 -- declaration and body satisfy the lock-free restrictions. 1820 1821 elsif not Lock_Free_Disabled 1822 and then Allows_Lock_Free_Implementation (Parent (Spec_Id)) 1823 and then Allows_Lock_Free_Implementation (N) 1824 then 1825 Set_Uses_Lock_Free (Spec_Id); 1826 end if; 1827 end Analyze_Protected_Body; 1828 1829 ---------------------------------- 1830 -- Analyze_Protected_Definition -- 1831 ---------------------------------- 1832 1833 procedure Analyze_Protected_Definition (N : Node_Id) is 1834 E : Entity_Id; 1835 L : Entity_Id; 1836 1837 procedure Undelay_Itypes (T : Entity_Id); 1838 -- Itypes created for the private components of a protected type 1839 -- do not receive freeze nodes, because there is no scope in which 1840 -- they can be elaborated, and they can depend on discriminants of 1841 -- the enclosed protected type. Given that the components can be 1842 -- composite types with inner components, we traverse recursively 1843 -- the private components of the protected type, and indicate that 1844 -- all itypes within are frozen. This ensures that no freeze nodes 1845 -- will be generated for them. 1846 -- 1847 -- On the other hand, components of the corresponding record are 1848 -- frozen (or receive itype references) as for other records. 1849 1850 -------------------- 1851 -- Undelay_Itypes -- 1852 -------------------- 1853 1854 procedure Undelay_Itypes (T : Entity_Id) is 1855 Comp : Entity_Id; 1856 1857 begin 1858 if Is_Protected_Type (T) then 1859 Comp := First_Private_Entity (T); 1860 elsif Is_Record_Type (T) then 1861 Comp := First_Entity (T); 1862 else 1863 return; 1864 end if; 1865 1866 while Present (Comp) loop 1867 if Is_Type (Comp) 1868 and then Is_Itype (Comp) 1869 then 1870 Set_Has_Delayed_Freeze (Comp, False); 1871 Set_Is_Frozen (Comp); 1872 1873 if Is_Record_Type (Comp) 1874 or else Is_Protected_Type (Comp) 1875 then 1876 Undelay_Itypes (Comp); 1877 end if; 1878 end if; 1879 1880 Next_Entity (Comp); 1881 end loop; 1882 end Undelay_Itypes; 1883 1884 -- Start of processing for Analyze_Protected_Definition 1885 1886 begin 1887 Tasking_Used := True; 1888 Check_SPARK_Restriction ("protected definition is not allowed", N); 1889 Analyze_Declarations (Visible_Declarations (N)); 1890 1891 if Present (Private_Declarations (N)) 1892 and then not Is_Empty_List (Private_Declarations (N)) 1893 then 1894 L := Last_Entity (Current_Scope); 1895 Analyze_Declarations (Private_Declarations (N)); 1896 1897 if Present (L) then 1898 Set_First_Private_Entity (Current_Scope, Next_Entity (L)); 1899 else 1900 Set_First_Private_Entity (Current_Scope, 1901 First_Entity (Current_Scope)); 1902 end if; 1903 end if; 1904 1905 E := First_Entity (Current_Scope); 1906 while Present (E) loop 1907 if Ekind_In (E, E_Function, E_Procedure) then 1908 Set_Convention (E, Convention_Protected); 1909 1910 elsif Is_Task_Type (Etype (E)) 1911 or else Has_Task (Etype (E)) 1912 then 1913 Set_Has_Task (Current_Scope); 1914 end if; 1915 1916 Next_Entity (E); 1917 end loop; 1918 1919 Undelay_Itypes (Current_Scope); 1920 1921 Check_Max_Entries (N, Max_Protected_Entries); 1922 Process_End_Label (N, 'e', Current_Scope); 1923 end Analyze_Protected_Definition; 1924 1925 ---------------------------------------- 1926 -- Analyze_Protected_Type_Declaration -- 1927 ---------------------------------------- 1928 1929 procedure Analyze_Protected_Type_Declaration (N : Node_Id) is 1930 Def_Id : constant Entity_Id := Defining_Identifier (N); 1931 E : Entity_Id; 1932 T : Entity_Id; 1933 1934 begin 1935 if No_Run_Time_Mode then 1936 Error_Msg_CRT ("protected type", N); 1937 1938 if Has_Aspects (N) then 1939 Analyze_Aspect_Specifications (N, Def_Id); 1940 end if; 1941 1942 return; 1943 end if; 1944 1945 Tasking_Used := True; 1946 Check_Restriction (No_Protected_Types, N); 1947 1948 T := Find_Type_Name (N); 1949 1950 -- In the case of an incomplete type, use the full view, unless it's not 1951 -- present (as can occur for an incomplete view from a limited with). 1952 1953 if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then 1954 T := Full_View (T); 1955 Set_Completion_Referenced (T); 1956 end if; 1957 1958 Set_Ekind (T, E_Protected_Type); 1959 Set_Is_First_Subtype (T, True); 1960 Init_Size_Align (T); 1961 Set_Etype (T, T); 1962 Set_Has_Delayed_Freeze (T, True); 1963 Set_Stored_Constraint (T, No_Elist); 1964 Push_Scope (T); 1965 1966 if Ada_Version >= Ada_2005 then 1967 Check_Interfaces (N, T); 1968 end if; 1969 1970 if Present (Discriminant_Specifications (N)) then 1971 if Has_Discriminants (T) then 1972 1973 -- Install discriminants. Also, verify conformance of 1974 -- discriminants of previous and current view. ??? 1975 1976 Install_Declarations (T); 1977 else 1978 Process_Discriminants (N); 1979 end if; 1980 end if; 1981 1982 Set_Is_Constrained (T, not Has_Discriminants (T)); 1983 1984 -- If aspects are present, analyze them now. They can make references 1985 -- to the discriminants of the type, but not to any components. 1986 1987 if Has_Aspects (N) then 1988 Analyze_Aspect_Specifications (N, Def_Id); 1989 end if; 1990 1991 Analyze (Protected_Definition (N)); 1992 1993 -- In the case where the protected type is declared at a nested level 1994 -- and the No_Local_Protected_Objects restriction applies, issue a 1995 -- warning that objects of the type will violate the restriction. 1996 1997 if Restriction_Check_Required (No_Local_Protected_Objects) 1998 and then not Is_Library_Level_Entity (T) 1999 and then Comes_From_Source (T) 2000 then 2001 Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); 2002 2003 if Error_Msg_Sloc = No_Location then 2004 Error_Msg_N 2005 ("objects of this type will violate " & 2006 "`No_Local_Protected_Objects`??", N); 2007 else 2008 Error_Msg_N 2009 ("objects of this type will violate " & 2010 "`No_Local_Protected_Objects`#??", N); 2011 end if; 2012 end if; 2013 2014 -- Protected types with entries are controlled (because of the 2015 -- Protection component if nothing else), same for any protected type 2016 -- with interrupt handlers. Note that we need to analyze the protected 2017 -- definition to set Has_Entries and such. 2018 2019 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False 2020 or else Number_Entries (T) > 1) 2021 and then 2022 (Has_Entries (T) 2023 or else Has_Interrupt_Handler (T) 2024 or else Has_Attach_Handler (T)) 2025 then 2026 Set_Has_Controlled_Component (T, True); 2027 end if; 2028 2029 -- The Ekind of components is E_Void during analysis to detect illegal 2030 -- uses. Now it can be set correctly. 2031 2032 E := First_Entity (Current_Scope); 2033 while Present (E) loop 2034 if Ekind (E) = E_Void then 2035 Set_Ekind (E, E_Component); 2036 Init_Component_Location (E); 2037 end if; 2038 2039 Next_Entity (E); 2040 end loop; 2041 2042 End_Scope; 2043 2044 -- When a Lock_Free aspect forces the lock-free implementation, check N 2045 -- meets all the lock-free restrictions. Otherwise, an error message is 2046 -- issued by Allows_Lock_Free_Implementation. 2047 2048 if Uses_Lock_Free (Defining_Identifier (N)) then 2049 2050 -- Complain when there is an explicit aspect/pragma Priority (or 2051 -- Interrupt_Priority) while the lock-free implementation is forced 2052 -- by an aspect/pragma. 2053 2054 declare 2055 Id : constant Entity_Id := Defining_Identifier (Original_Node (N)); 2056 -- The warning must be issued on the original identifier in order 2057 -- to deal properly with the case of a single protected object. 2058 2059 Prio_Item : constant Node_Id := 2060 Get_Rep_Item (Def_Id, Name_Priority, False); 2061 2062 begin 2063 if Present (Prio_Item) then 2064 2065 -- Aspect case 2066 2067 if Nkind (Prio_Item) = N_Aspect_Specification 2068 or else From_Aspect_Specification (Prio_Item) 2069 then 2070 Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); 2071 Error_Msg_NE ("aspect% for & has no effect when Lock_Free" & 2072 " given??", Prio_Item, Id); 2073 2074 -- Pragma case 2075 2076 else 2077 Error_Msg_Name_1 := Pragma_Name (Prio_Item); 2078 Error_Msg_NE ("pragma% for & has no effect when Lock_Free" & 2079 " given??", Prio_Item, Id); 2080 end if; 2081 end if; 2082 end; 2083 2084 if not Allows_Lock_Free_Implementation (N, True) then 2085 return; 2086 end if; 2087 end if; 2088 2089 -- If the Attach_Handler aspect is specified or the Interrupt_Handler 2090 -- aspect is True, then the initial ceiling priority must be in the 2091 -- range of System.Interrupt_Priority. It is therefore recommanded 2092 -- to use the Interrupt_Priority aspect instead of the Priority aspect. 2093 2094 if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then 2095 declare 2096 Prio_Item : constant Node_Id := 2097 Get_Rep_Item (Def_Id, Name_Priority, False); 2098 2099 begin 2100 if Present (Prio_Item) then 2101 2102 -- Aspect case 2103 2104 if (Nkind (Prio_Item) = N_Aspect_Specification 2105 or else From_Aspect_Specification (Prio_Item)) 2106 and then Chars (Identifier (Prio_Item)) = Name_Priority 2107 then 2108 Error_Msg_N ("aspect Interrupt_Priority is preferred " 2109 & "in presence of handlers??", Prio_Item); 2110 2111 -- Pragma case 2112 2113 elsif Nkind (Prio_Item) = N_Pragma 2114 and then Pragma_Name (Prio_Item) = Name_Priority 2115 then 2116 Error_Msg_N ("pragma Interrupt_Priority is preferred " 2117 & "in presence of handlers??", Prio_Item); 2118 end if; 2119 end if; 2120 end; 2121 end if; 2122 2123 -- Case of a completion of a private declaration 2124 2125 if T /= Def_Id and then Is_Private_Type (Def_Id) then 2126 2127 -- Deal with preelaborable initialization. Note that this processing 2128 -- is done by Process_Full_View, but as can be seen below, in this 2129 -- case the call to Process_Full_View is skipped if any serious 2130 -- errors have occurred, and we don't want to lose this check. 2131 2132 if Known_To_Have_Preelab_Init (Def_Id) then 2133 Set_Must_Have_Preelab_Init (T); 2134 end if; 2135 2136 -- Create corresponding record now, because some private dependents 2137 -- may be subtypes of the partial view. 2138 2139 -- Skip if errors are present, to prevent cascaded messages 2140 2141 if Serious_Errors_Detected = 0 2142 2143 -- Also skip if expander is not active 2144 2145 and then Expander_Active 2146 then 2147 Expand_N_Protected_Type_Declaration (N); 2148 Process_Full_View (N, T, Def_Id); 2149 end if; 2150 end if; 2151 end Analyze_Protected_Type_Declaration; 2152 2153 --------------------- 2154 -- Analyze_Requeue -- 2155 --------------------- 2156 2157 procedure Analyze_Requeue (N : Node_Id) is 2158 Count : Natural := 0; 2159 Entry_Name : Node_Id := Name (N); 2160 Entry_Id : Entity_Id; 2161 I : Interp_Index; 2162 Is_Disp_Req : Boolean; 2163 It : Interp; 2164 Enclosing : Entity_Id; 2165 Target_Obj : Node_Id := Empty; 2166 Req_Scope : Entity_Id; 2167 Outer_Ent : Entity_Id; 2168 Synch_Type : Entity_Id; 2169 2170 begin 2171 Tasking_Used := True; 2172 Check_SPARK_Restriction ("requeue statement is not allowed", N); 2173 Check_Restriction (No_Requeue_Statements, N); 2174 Check_Unreachable_Code (N); 2175 2176 Enclosing := Empty; 2177 for J in reverse 0 .. Scope_Stack.Last loop 2178 Enclosing := Scope_Stack.Table (J).Entity; 2179 exit when Is_Entry (Enclosing); 2180 2181 if not Ekind_In (Enclosing, E_Block, E_Loop) then 2182 Error_Msg_N ("requeue must appear within accept or entry body", N); 2183 return; 2184 end if; 2185 end loop; 2186 2187 Analyze (Entry_Name); 2188 2189 if Etype (Entry_Name) = Any_Type then 2190 return; 2191 end if; 2192 2193 if Nkind (Entry_Name) = N_Selected_Component then 2194 Target_Obj := Prefix (Entry_Name); 2195 Entry_Name := Selector_Name (Entry_Name); 2196 end if; 2197 2198 -- If an explicit target object is given then we have to check the 2199 -- restrictions of 9.5.4(6). 2200 2201 if Present (Target_Obj) then 2202 2203 -- Locate containing concurrent unit and determine enclosing entry 2204 -- body or outermost enclosing accept statement within the unit. 2205 2206 Outer_Ent := Empty; 2207 for S in reverse 0 .. Scope_Stack.Last loop 2208 Req_Scope := Scope_Stack.Table (S).Entity; 2209 2210 exit when Ekind (Req_Scope) in Task_Kind 2211 or else Ekind (Req_Scope) in Protected_Kind; 2212 2213 if Is_Entry (Req_Scope) then 2214 Outer_Ent := Req_Scope; 2215 end if; 2216 end loop; 2217 2218 pragma Assert (Present (Outer_Ent)); 2219 2220 -- Check that the accessibility level of the target object is not 2221 -- greater or equal to the outermost enclosing accept statement (or 2222 -- entry body) unless it is a parameter of the innermost enclosing 2223 -- accept statement (or entry body). 2224 2225 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) 2226 and then 2227 (not Is_Entity_Name (Target_Obj) 2228 or else Ekind (Entity (Target_Obj)) not in Formal_Kind 2229 or else Enclosing /= Scope (Entity (Target_Obj))) 2230 then 2231 Error_Msg_N 2232 ("target object has invalid level for requeue", Target_Obj); 2233 end if; 2234 end if; 2235 2236 -- Overloaded case, find right interpretation 2237 2238 if Is_Overloaded (Entry_Name) then 2239 Entry_Id := Empty; 2240 2241 -- Loop over candidate interpretations and filter out any that are 2242 -- not parameterless, are not type conformant, are not entries, or 2243 -- do not come from source. 2244 2245 Get_First_Interp (Entry_Name, I, It); 2246 while Present (It.Nam) loop 2247 2248 -- Note: we test type conformance here, not subtype conformance. 2249 -- Subtype conformance will be tested later on, but it is better 2250 -- for error output in some cases not to do that here. 2251 2252 if (No (First_Formal (It.Nam)) 2253 or else (Type_Conformant (Enclosing, It.Nam))) 2254 and then Ekind (It.Nam) = E_Entry 2255 then 2256 -- Ada 2005 (AI-345): Since protected and task types have 2257 -- primitive entry wrappers, we only consider source entries. 2258 2259 if Comes_From_Source (It.Nam) then 2260 Count := Count + 1; 2261 Entry_Id := It.Nam; 2262 else 2263 Remove_Interp (I); 2264 end if; 2265 end if; 2266 2267 Get_Next_Interp (I, It); 2268 end loop; 2269 2270 if Count = 0 then 2271 Error_Msg_N ("no entry matches context", N); 2272 return; 2273 2274 elsif Count > 1 then 2275 Error_Msg_N ("ambiguous entry name in requeue", N); 2276 return; 2277 2278 else 2279 Set_Is_Overloaded (Entry_Name, False); 2280 Set_Entity (Entry_Name, Entry_Id); 2281 end if; 2282 2283 -- Non-overloaded cases 2284 2285 -- For the case of a reference to an element of an entry family, the 2286 -- Entry_Name is an indexed component. 2287 2288 elsif Nkind (Entry_Name) = N_Indexed_Component then 2289 2290 -- Requeue to an entry out of the body 2291 2292 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then 2293 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name))); 2294 2295 -- Requeue from within the body itself 2296 2297 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then 2298 Entry_Id := Entity (Prefix (Entry_Name)); 2299 2300 else 2301 Error_Msg_N ("invalid entry_name specified", N); 2302 return; 2303 end if; 2304 2305 -- If we had a requeue of the form REQUEUE A (B), then the parser 2306 -- accepted it (because it could have been a requeue on an entry index. 2307 -- If A turns out not to be an entry family, then the analysis of A (B) 2308 -- turned it into a function call. 2309 2310 elsif Nkind (Entry_Name) = N_Function_Call then 2311 Error_Msg_N 2312 ("arguments not allowed in requeue statement", 2313 First (Parameter_Associations (Entry_Name))); 2314 return; 2315 2316 -- Normal case of no entry family, no argument 2317 2318 else 2319 Entry_Id := Entity (Entry_Name); 2320 end if; 2321 2322 -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The 2323 -- target type must be a concurrent interface class-wide type and the 2324 -- target must be a procedure, flagged by pragma Implemented. The 2325 -- target may be an access to class-wide type, in which case it must 2326 -- be dereferenced. 2327 2328 if Present (Target_Obj) then 2329 Synch_Type := Etype (Target_Obj); 2330 2331 if Is_Access_Type (Synch_Type) then 2332 Synch_Type := Designated_Type (Synch_Type); 2333 end if; 2334 end if; 2335 2336 Is_Disp_Req := 2337 Ada_Version >= Ada_2012 2338 and then Present (Target_Obj) 2339 and then Is_Class_Wide_Type (Synch_Type) 2340 and then Is_Concurrent_Interface (Synch_Type) 2341 and then Ekind (Entry_Id) = E_Procedure 2342 and then Has_Rep_Pragma (Entry_Id, Name_Implemented); 2343 2344 -- Resolve entry, and check that it is subtype conformant with the 2345 -- enclosing construct if this construct has formals (RM 9.5.4(5)). 2346 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case. 2347 2348 if not Is_Entry (Entry_Id) 2349 and then not Is_Disp_Req 2350 then 2351 Error_Msg_N ("expect entry name in requeue statement", Name (N)); 2352 2353 elsif Ekind (Entry_Id) = E_Entry_Family 2354 and then Nkind (Entry_Name) /= N_Indexed_Component 2355 then 2356 Error_Msg_N ("missing index for entry family component", Name (N)); 2357 2358 else 2359 Resolve_Entry (Name (N)); 2360 Generate_Reference (Entry_Id, Entry_Name); 2361 2362 if Present (First_Formal (Entry_Id)) then 2363 if VM_Target = JVM_Target then 2364 Error_Msg_N 2365 ("arguments unsupported in requeue statement", 2366 First_Formal (Entry_Id)); 2367 return; 2368 end if; 2369 2370 -- Ada 2012 (AI05-0030): Perform type conformance after skipping 2371 -- the first parameter of Entry_Id since it is the interface 2372 -- controlling formal. 2373 2374 if Ada_Version >= Ada_2012 and then Is_Disp_Req then 2375 declare 2376 Enclosing_Formal : Entity_Id; 2377 Target_Formal : Entity_Id; 2378 2379 begin 2380 Enclosing_Formal := First_Formal (Enclosing); 2381 Target_Formal := Next_Formal (First_Formal (Entry_Id)); 2382 while Present (Enclosing_Formal) 2383 and then Present (Target_Formal) 2384 loop 2385 if not Conforming_Types 2386 (T1 => Etype (Enclosing_Formal), 2387 T2 => Etype (Target_Formal), 2388 Ctype => Subtype_Conformant) 2389 then 2390 Error_Msg_Node_2 := Target_Formal; 2391 Error_Msg_NE 2392 ("formal & is not subtype conformant with &" & 2393 "in dispatching requeue", N, Enclosing_Formal); 2394 end if; 2395 2396 Next_Formal (Enclosing_Formal); 2397 Next_Formal (Target_Formal); 2398 end loop; 2399 end; 2400 else 2401 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); 2402 end if; 2403 2404 -- Processing for parameters accessed by the requeue 2405 2406 declare 2407 Ent : Entity_Id; 2408 2409 begin 2410 Ent := First_Formal (Enclosing); 2411 while Present (Ent) loop 2412 2413 -- For OUT or IN OUT parameter, the effect of the requeue is 2414 -- to assign the parameter a value on exit from the requeued 2415 -- body, so we can set it as source assigned. We also clear 2416 -- the Is_True_Constant indication. We do not need to clear 2417 -- Current_Value, since the effect of the requeue is to 2418 -- perform an unconditional goto so that any further 2419 -- references will not occur anyway. 2420 2421 if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then 2422 Set_Never_Set_In_Source (Ent, False); 2423 Set_Is_True_Constant (Ent, False); 2424 end if; 2425 2426 -- For all parameters, the requeue acts as a reference, 2427 -- since the value of the parameter is passed to the new 2428 -- entry, so we want to suppress unreferenced warnings. 2429 2430 Set_Referenced (Ent); 2431 Next_Formal (Ent); 2432 end loop; 2433 end; 2434 end if; 2435 end if; 2436 2437 -- AI05-0225: the target protected object of a requeue must be a 2438 -- variable. This is a binding interpretation that applies to all 2439 -- versions of the language. 2440 2441 if Present (Target_Obj) 2442 and then Ekind (Scope (Entry_Id)) in Protected_Kind 2443 and then not Is_Variable (Target_Obj) 2444 then 2445 Error_Msg_N 2446 ("target protected object of requeue must be a variable", N); 2447 end if; 2448 end Analyze_Requeue; 2449 2450 ------------------------------ 2451 -- Analyze_Selective_Accept -- 2452 ------------------------------ 2453 2454 procedure Analyze_Selective_Accept (N : Node_Id) is 2455 Alts : constant List_Id := Select_Alternatives (N); 2456 Alt : Node_Id; 2457 2458 Accept_Present : Boolean := False; 2459 Terminate_Present : Boolean := False; 2460 Delay_Present : Boolean := False; 2461 Relative_Present : Boolean := False; 2462 Alt_Count : Uint := Uint_0; 2463 2464 begin 2465 Tasking_Used := True; 2466 Check_SPARK_Restriction ("select statement is not allowed", N); 2467 Check_Restriction (No_Select_Statements, N); 2468 2469 -- Loop to analyze alternatives 2470 2471 Alt := First (Alts); 2472 while Present (Alt) loop 2473 Alt_Count := Alt_Count + 1; 2474 Analyze (Alt); 2475 2476 if Nkind (Alt) = N_Delay_Alternative then 2477 if Delay_Present then 2478 2479 if Relative_Present /= 2480 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement) 2481 then 2482 Error_Msg_N 2483 ("delay_until and delay_relative alternatives ", Alt); 2484 Error_Msg_N 2485 ("\cannot appear in the same selective_wait", Alt); 2486 end if; 2487 2488 else 2489 Delay_Present := True; 2490 Relative_Present := 2491 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement; 2492 end if; 2493 2494 elsif Nkind (Alt) = N_Terminate_Alternative then 2495 if Terminate_Present then 2496 Error_Msg_N ("only one terminate alternative allowed", N); 2497 else 2498 Terminate_Present := True; 2499 Check_Restriction (No_Terminate_Alternatives, N); 2500 end if; 2501 2502 elsif Nkind (Alt) = N_Accept_Alternative then 2503 Accept_Present := True; 2504 2505 -- Check for duplicate accept 2506 2507 declare 2508 Alt1 : Node_Id; 2509 Stm : constant Node_Id := Accept_Statement (Alt); 2510 EDN : constant Node_Id := Entry_Direct_Name (Stm); 2511 Ent : Entity_Id; 2512 2513 begin 2514 if Nkind (EDN) = N_Identifier 2515 and then No (Condition (Alt)) 2516 and then Present (Entity (EDN)) -- defend against junk 2517 and then Ekind (Entity (EDN)) = E_Entry 2518 then 2519 Ent := Entity (EDN); 2520 2521 Alt1 := First (Alts); 2522 while Alt1 /= Alt loop 2523 if Nkind (Alt1) = N_Accept_Alternative 2524 and then No (Condition (Alt1)) 2525 then 2526 declare 2527 Stm1 : constant Node_Id := Accept_Statement (Alt1); 2528 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1); 2529 2530 begin 2531 if Nkind (EDN1) = N_Identifier then 2532 if Entity (EDN1) = Ent then 2533 Error_Msg_Sloc := Sloc (Stm1); 2534 Error_Msg_N 2535 ("accept duplicates one on line#??", Stm); 2536 exit; 2537 end if; 2538 end if; 2539 end; 2540 end if; 2541 2542 Next (Alt1); 2543 end loop; 2544 end if; 2545 end; 2546 end if; 2547 2548 Next (Alt); 2549 end loop; 2550 2551 Check_Restriction (Max_Select_Alternatives, N, Alt_Count); 2552 Check_Potentially_Blocking_Operation (N); 2553 2554 if Terminate_Present and Delay_Present then 2555 Error_Msg_N ("at most one of terminate or delay alternative", N); 2556 2557 elsif not Accept_Present then 2558 Error_Msg_N 2559 ("select must contain at least one accept alternative", N); 2560 end if; 2561 2562 if Present (Else_Statements (N)) then 2563 if Terminate_Present or Delay_Present then 2564 Error_Msg_N ("else part not allowed with other alternatives", N); 2565 end if; 2566 2567 Analyze_Statements (Else_Statements (N)); 2568 end if; 2569 end Analyze_Selective_Accept; 2570 2571 ------------------------------------------ 2572 -- Analyze_Single_Protected_Declaration -- 2573 ------------------------------------------ 2574 2575 procedure Analyze_Single_Protected_Declaration (N : Node_Id) is 2576 Loc : constant Source_Ptr := Sloc (N); 2577 Id : constant Node_Id := Defining_Identifier (N); 2578 T : Entity_Id; 2579 T_Decl : Node_Id; 2580 O_Decl : Node_Id; 2581 O_Name : constant Entity_Id := Id; 2582 2583 begin 2584 Generate_Definition (Id); 2585 Tasking_Used := True; 2586 2587 -- The node is rewritten as a protected type declaration, in exact 2588 -- analogy with what is done with single tasks. 2589 2590 T := 2591 Make_Defining_Identifier (Sloc (Id), 2592 New_External_Name (Chars (Id), 'T')); 2593 2594 T_Decl := 2595 Make_Protected_Type_Declaration (Loc, 2596 Defining_Identifier => T, 2597 Protected_Definition => Relocate_Node (Protected_Definition (N)), 2598 Interface_List => Interface_List (N)); 2599 2600 O_Decl := 2601 Make_Object_Declaration (Loc, 2602 Defining_Identifier => O_Name, 2603 Object_Definition => Make_Identifier (Loc, Chars (T))); 2604 2605 Rewrite (N, T_Decl); 2606 Insert_After (N, O_Decl); 2607 Mark_Rewrite_Insertion (O_Decl); 2608 2609 -- Enter names of type and object before analysis, because the name of 2610 -- the object may be used in its own body. 2611 2612 Enter_Name (T); 2613 Set_Ekind (T, E_Protected_Type); 2614 Set_Etype (T, T); 2615 2616 Enter_Name (O_Name); 2617 Set_Ekind (O_Name, E_Variable); 2618 Set_Etype (O_Name, T); 2619 2620 -- Instead of calling Analyze on the new node, call the proper analysis 2621 -- procedure directly. Otherwise the node would be expanded twice, with 2622 -- disastrous result. 2623 2624 Analyze_Protected_Type_Declaration (N); 2625 2626 if Has_Aspects (N) then 2627 Analyze_Aspect_Specifications (N, Id); 2628 end if; 2629 end Analyze_Single_Protected_Declaration; 2630 2631 ------------------------------------- 2632 -- Analyze_Single_Task_Declaration -- 2633 ------------------------------------- 2634 2635 procedure Analyze_Single_Task_Declaration (N : Node_Id) is 2636 Loc : constant Source_Ptr := Sloc (N); 2637 Id : constant Node_Id := Defining_Identifier (N); 2638 T : Entity_Id; 2639 T_Decl : Node_Id; 2640 O_Decl : Node_Id; 2641 O_Name : constant Entity_Id := Id; 2642 2643 begin 2644 Generate_Definition (Id); 2645 Tasking_Used := True; 2646 2647 -- The node is rewritten as a task type declaration, followed by an 2648 -- object declaration of that anonymous task type. 2649 2650 T := 2651 Make_Defining_Identifier (Sloc (Id), 2652 New_External_Name (Chars (Id), Suffix => "TK")); 2653 2654 T_Decl := 2655 Make_Task_Type_Declaration (Loc, 2656 Defining_Identifier => T, 2657 Task_Definition => Relocate_Node (Task_Definition (N)), 2658 Interface_List => Interface_List (N)); 2659 2660 -- We use the original defining identifier of the single task in the 2661 -- generated object declaration, so that debugging information can 2662 -- be attached to it when compiling with -gnatD. The parent of the 2663 -- entity is the new object declaration. The single_task_declaration 2664 -- is not used further in semantics or code generation, but is scanned 2665 -- when generating debug information, and therefore needs the updated 2666 -- Sloc information for the entity (see Sprint). Aspect specifications 2667 -- are moved from the single task node to the object declaration node. 2668 2669 O_Decl := 2670 Make_Object_Declaration (Loc, 2671 Defining_Identifier => O_Name, 2672 Object_Definition => Make_Identifier (Loc, Chars (T))); 2673 2674 Rewrite (N, T_Decl); 2675 Insert_After (N, O_Decl); 2676 Mark_Rewrite_Insertion (O_Decl); 2677 2678 -- Enter names of type and object before analysis, because the name of 2679 -- the object may be used in its own body. 2680 2681 Enter_Name (T); 2682 Set_Ekind (T, E_Task_Type); 2683 Set_Etype (T, T); 2684 2685 Enter_Name (O_Name); 2686 Set_Ekind (O_Name, E_Variable); 2687 Set_Etype (O_Name, T); 2688 2689 -- Instead of calling Analyze on the new node, call the proper analysis 2690 -- procedure directly. Otherwise the node would be expanded twice, with 2691 -- disastrous result. 2692 2693 Analyze_Task_Type_Declaration (N); 2694 2695 if Has_Aspects (N) then 2696 Analyze_Aspect_Specifications (N, Id); 2697 end if; 2698 end Analyze_Single_Task_Declaration; 2699 2700 ----------------------- 2701 -- Analyze_Task_Body -- 2702 ----------------------- 2703 2704 procedure Analyze_Task_Body (N : Node_Id) is 2705 Body_Id : constant Entity_Id := Defining_Identifier (N); 2706 Decls : constant List_Id := Declarations (N); 2707 HSS : constant Node_Id := Handled_Statement_Sequence (N); 2708 Last_E : Entity_Id; 2709 2710 Spec_Id : Entity_Id; 2711 -- This is initially the entity of the task or task type involved, but 2712 -- is replaced by the task type always in the case of a single task 2713 -- declaration, since this is the proper scope to be used. 2714 2715 Ref_Id : Entity_Id; 2716 -- This is the entity of the task or task type, and is the entity used 2717 -- for cross-reference purposes (it differs from Spec_Id in the case of 2718 -- a single task, since Spec_Id is set to the task type). 2719 2720 begin 2721 Tasking_Used := True; 2722 Set_Ekind (Body_Id, E_Task_Body); 2723 Set_Scope (Body_Id, Current_Scope); 2724 Spec_Id := Find_Concurrent_Spec (Body_Id); 2725 2726 -- Task bodies are transformed into a subprogram spec and body pair by 2727 -- the expander. Since there are no language-defined aspects that apply 2728 -- to a task body, it is not worth changing the whole expansion to 2729 -- accomodate implementation-defined aspects. Plus we cannot possibly 2730 -- know semantics of such aspects in order to plan ahead. 2731 2732 if Has_Aspects (N) then 2733 Error_Msg_N 2734 ("aspects on task bodies are not allowed", 2735 First (Aspect_Specifications (N))); 2736 2737 -- Remove illegal aspects to prevent cascaded errors later on 2738 2739 Remove_Aspects (N); 2740 end if; 2741 2742 -- The spec is either a task type declaration, or a single task 2743 -- declaration for which we have created an anonymous type. 2744 2745 if Present (Spec_Id) 2746 and then Ekind (Spec_Id) = E_Task_Type 2747 then 2748 null; 2749 2750 elsif Present (Spec_Id) 2751 and then Ekind (Etype (Spec_Id)) = E_Task_Type 2752 and then not Comes_From_Source (Etype (Spec_Id)) 2753 then 2754 null; 2755 2756 else 2757 Error_Msg_N ("missing specification for task body", Body_Id); 2758 return; 2759 end if; 2760 2761 if Has_Completion (Spec_Id) 2762 and then Present (Corresponding_Body (Parent (Spec_Id))) 2763 then 2764 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then 2765 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id); 2766 else 2767 Error_Msg_NE ("duplicate body for task&", N, Spec_Id); 2768 end if; 2769 end if; 2770 2771 Ref_Id := Spec_Id; 2772 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); 2773 Style.Check_Identifier (Body_Id, Spec_Id); 2774 2775 -- Deal with case of body of single task (anonymous type was created) 2776 2777 if Ekind (Spec_Id) = E_Variable then 2778 Spec_Id := Etype (Spec_Id); 2779 end if; 2780 2781 Push_Scope (Spec_Id); 2782 Set_Corresponding_Spec (N, Spec_Id); 2783 Set_Corresponding_Body (Parent (Spec_Id), Body_Id); 2784 Set_Has_Completion (Spec_Id); 2785 Install_Declarations (Spec_Id); 2786 Last_E := Last_Entity (Spec_Id); 2787 2788 Analyze_Declarations (Decls); 2789 Inspect_Deferred_Constant_Completion (Decls); 2790 2791 -- For visibility purposes, all entities in the body are private. Set 2792 -- First_Private_Entity accordingly, if there was no private part in the 2793 -- protected declaration. 2794 2795 if No (First_Private_Entity (Spec_Id)) then 2796 if Present (Last_E) then 2797 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); 2798 else 2799 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); 2800 end if; 2801 end if; 2802 2803 -- Mark all handlers as not suitable for local raise optimization, 2804 -- since this optimization causes difficulties in a task context. 2805 2806 if Present (Exception_Handlers (HSS)) then 2807 declare 2808 Handlr : Node_Id; 2809 begin 2810 Handlr := First (Exception_Handlers (HSS)); 2811 while Present (Handlr) loop 2812 Set_Local_Raise_Not_OK (Handlr); 2813 Next (Handlr); 2814 end loop; 2815 end; 2816 end if; 2817 2818 -- Now go ahead and complete analysis of the task body 2819 2820 Analyze (HSS); 2821 Check_Completion (Body_Id); 2822 Check_References (Body_Id); 2823 Check_References (Spec_Id); 2824 2825 -- Check for entries with no corresponding accept 2826 2827 declare 2828 Ent : Entity_Id; 2829 2830 begin 2831 Ent := First_Entity (Spec_Id); 2832 while Present (Ent) loop 2833 if Is_Entry (Ent) 2834 and then not Entry_Accepted (Ent) 2835 and then Comes_From_Source (Ent) 2836 then 2837 Error_Msg_NE ("no accept for entry &??", N, Ent); 2838 end if; 2839 2840 Next_Entity (Ent); 2841 end loop; 2842 end; 2843 2844 Process_End_Label (HSS, 't', Ref_Id); 2845 End_Scope; 2846 end Analyze_Task_Body; 2847 2848 ----------------------------- 2849 -- Analyze_Task_Definition -- 2850 ----------------------------- 2851 2852 procedure Analyze_Task_Definition (N : Node_Id) is 2853 L : Entity_Id; 2854 2855 begin 2856 Tasking_Used := True; 2857 Check_SPARK_Restriction ("task definition is not allowed", N); 2858 2859 if Present (Visible_Declarations (N)) then 2860 Analyze_Declarations (Visible_Declarations (N)); 2861 end if; 2862 2863 if Present (Private_Declarations (N)) then 2864 L := Last_Entity (Current_Scope); 2865 Analyze_Declarations (Private_Declarations (N)); 2866 2867 if Present (L) then 2868 Set_First_Private_Entity 2869 (Current_Scope, Next_Entity (L)); 2870 else 2871 Set_First_Private_Entity 2872 (Current_Scope, First_Entity (Current_Scope)); 2873 end if; 2874 end if; 2875 2876 Check_Max_Entries (N, Max_Task_Entries); 2877 Process_End_Label (N, 'e', Current_Scope); 2878 end Analyze_Task_Definition; 2879 2880 ----------------------------------- 2881 -- Analyze_Task_Type_Declaration -- 2882 ----------------------------------- 2883 2884 procedure Analyze_Task_Type_Declaration (N : Node_Id) is 2885 Def_Id : constant Entity_Id := Defining_Identifier (N); 2886 T : Entity_Id; 2887 2888 begin 2889 Check_Restriction (No_Tasking, N); 2890 Tasking_Used := True; 2891 T := Find_Type_Name (N); 2892 Generate_Definition (T); 2893 2894 -- In the case of an incomplete type, use the full view, unless it's not 2895 -- present (as can occur for an incomplete view from a limited with). 2896 -- Initialize the Corresponding_Record_Type (which overlays the Private 2897 -- Dependents field of the incomplete view). 2898 2899 if Ekind (T) = E_Incomplete_Type then 2900 if Present (Full_View (T)) then 2901 T := Full_View (T); 2902 Set_Completion_Referenced (T); 2903 2904 else 2905 Set_Ekind (T, E_Task_Type); 2906 Set_Corresponding_Record_Type (T, Empty); 2907 end if; 2908 end if; 2909 2910 Set_Ekind (T, E_Task_Type); 2911 Set_Is_First_Subtype (T, True); 2912 Set_Has_Task (T, True); 2913 Init_Size_Align (T); 2914 Set_Etype (T, T); 2915 Set_Has_Delayed_Freeze (T, True); 2916 Set_Stored_Constraint (T, No_Elist); 2917 Push_Scope (T); 2918 2919 if Ada_Version >= Ada_2005 then 2920 Check_Interfaces (N, T); 2921 end if; 2922 2923 if Present (Discriminant_Specifications (N)) then 2924 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 2925 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); 2926 end if; 2927 2928 if Has_Discriminants (T) then 2929 2930 -- Install discriminants. Also, verify conformance of 2931 -- discriminants of previous and current view. ??? 2932 2933 Install_Declarations (T); 2934 else 2935 Process_Discriminants (N); 2936 end if; 2937 end if; 2938 2939 Set_Is_Constrained (T, not Has_Discriminants (T)); 2940 2941 if Has_Aspects (N) then 2942 Analyze_Aspect_Specifications (N, Def_Id); 2943 end if; 2944 2945 if Present (Task_Definition (N)) then 2946 Analyze_Task_Definition (Task_Definition (N)); 2947 end if; 2948 2949 -- In the case where the task type is declared at a nested level and the 2950 -- No_Task_Hierarchy restriction applies, issue a warning that objects 2951 -- of the type will violate the restriction. 2952 2953 if Restriction_Check_Required (No_Task_Hierarchy) 2954 and then not Is_Library_Level_Entity (T) 2955 and then Comes_From_Source (T) 2956 then 2957 Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); 2958 2959 if Error_Msg_Sloc = No_Location then 2960 Error_Msg_N 2961 ("objects of this type will violate `No_Task_Hierarchy`??", N); 2962 else 2963 Error_Msg_N 2964 ("objects of this type will violate `No_Task_Hierarchy`#??", N); 2965 end if; 2966 end if; 2967 2968 End_Scope; 2969 2970 -- Case of a completion of a private declaration 2971 2972 if T /= Def_Id 2973 and then Is_Private_Type (Def_Id) 2974 then 2975 -- Deal with preelaborable initialization. Note that this processing 2976 -- is done by Process_Full_View, but as can be seen below, in this 2977 -- case the call to Process_Full_View is skipped if any serious 2978 -- errors have occurred, and we don't want to lose this check. 2979 2980 if Known_To_Have_Preelab_Init (Def_Id) then 2981 Set_Must_Have_Preelab_Init (T); 2982 end if; 2983 2984 -- Create corresponding record now, because some private dependents 2985 -- may be subtypes of the partial view. 2986 2987 -- Skip if errors are present, to prevent cascaded messages 2988 2989 if Serious_Errors_Detected = 0 2990 2991 -- Also skip if expander is not active 2992 2993 and then Expander_Active 2994 then 2995 Expand_N_Task_Type_Declaration (N); 2996 Process_Full_View (N, T, Def_Id); 2997 end if; 2998 end if; 2999 end Analyze_Task_Type_Declaration; 3000 3001 ----------------------------------- 3002 -- Analyze_Terminate_Alternative -- 3003 ----------------------------------- 3004 3005 procedure Analyze_Terminate_Alternative (N : Node_Id) is 3006 begin 3007 Tasking_Used := True; 3008 3009 if Present (Pragmas_Before (N)) then 3010 Analyze_List (Pragmas_Before (N)); 3011 end if; 3012 3013 if Present (Condition (N)) then 3014 Analyze_And_Resolve (Condition (N), Any_Boolean); 3015 end if; 3016 end Analyze_Terminate_Alternative; 3017 3018 ------------------------------ 3019 -- Analyze_Timed_Entry_Call -- 3020 ------------------------------ 3021 3022 procedure Analyze_Timed_Entry_Call (N : Node_Id) is 3023 Trigger : constant Node_Id := 3024 Entry_Call_Statement (Entry_Call_Alternative (N)); 3025 Is_Disp_Select : Boolean := False; 3026 3027 begin 3028 Tasking_Used := True; 3029 Check_SPARK_Restriction ("select statement is not allowed", N); 3030 Check_Restriction (No_Select_Statements, N); 3031 3032 -- Ada 2005 (AI-345): The trigger may be a dispatching call 3033 3034 if Ada_Version >= Ada_2005 then 3035 Analyze (Trigger); 3036 Check_Triggering_Statement (Trigger, N, Is_Disp_Select); 3037 end if; 3038 3039 -- Postpone the analysis of the statements till expansion. Analyze only 3040 -- if the expander is disabled in order to catch any semantic errors. 3041 3042 if Is_Disp_Select then 3043 if not Expander_Active then 3044 Analyze (Entry_Call_Alternative (N)); 3045 Analyze (Delay_Alternative (N)); 3046 end if; 3047 3048 -- Regular select analysis 3049 3050 else 3051 Analyze (Entry_Call_Alternative (N)); 3052 Analyze (Delay_Alternative (N)); 3053 end if; 3054 end Analyze_Timed_Entry_Call; 3055 3056 ------------------------------------ 3057 -- Analyze_Triggering_Alternative -- 3058 ------------------------------------ 3059 3060 procedure Analyze_Triggering_Alternative (N : Node_Id) is 3061 Trigger : constant Node_Id := Triggering_Statement (N); 3062 3063 begin 3064 Tasking_Used := True; 3065 3066 if Present (Pragmas_Before (N)) then 3067 Analyze_List (Pragmas_Before (N)); 3068 end if; 3069 3070 Analyze (Trigger); 3071 3072 if Comes_From_Source (Trigger) 3073 and then Nkind (Trigger) not in N_Delay_Statement 3074 and then Nkind (Trigger) /= N_Entry_Call_Statement 3075 then 3076 if Ada_Version < Ada_2005 then 3077 Error_Msg_N 3078 ("triggering statement must be delay or entry call", Trigger); 3079 3080 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a 3081 -- procedure_or_entry_call, the procedure_name or procedure_prefix 3082 -- of the procedure_call_statement shall denote an entry renamed by a 3083 -- procedure, or (a view of) a primitive subprogram of a limited 3084 -- interface whose first parameter is a controlling parameter. 3085 3086 elsif Nkind (Trigger) = N_Procedure_Call_Statement 3087 and then not Is_Renamed_Entry (Entity (Name (Trigger))) 3088 and then not Is_Controlling_Limited_Procedure 3089 (Entity (Name (Trigger))) 3090 then 3091 Error_Msg_N 3092 ("triggering statement must be procedure or entry call " & 3093 "or delay statement", Trigger); 3094 end if; 3095 end if; 3096 3097 if Is_Non_Empty_List (Statements (N)) then 3098 Analyze_Statements (Statements (N)); 3099 end if; 3100 end Analyze_Triggering_Alternative; 3101 3102 ----------------------- 3103 -- Check_Max_Entries -- 3104 ----------------------- 3105 3106 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is 3107 Ecount : Uint; 3108 3109 procedure Count (L : List_Id); 3110 -- Count entries in given declaration list 3111 3112 ----------- 3113 -- Count -- 3114 ----------- 3115 3116 procedure Count (L : List_Id) is 3117 D : Node_Id; 3118 3119 begin 3120 if No (L) then 3121 return; 3122 end if; 3123 3124 D := First (L); 3125 while Present (D) loop 3126 if Nkind (D) = N_Entry_Declaration then 3127 declare 3128 DSD : constant Node_Id := 3129 Discrete_Subtype_Definition (D); 3130 3131 begin 3132 -- If not an entry family, then just one entry 3133 3134 if No (DSD) then 3135 Ecount := Ecount + 1; 3136 3137 -- If entry family with static bounds, count entries 3138 3139 elsif Is_OK_Static_Subtype (Etype (DSD)) then 3140 declare 3141 Lo : constant Uint := 3142 Expr_Value 3143 (Type_Low_Bound (Etype (DSD))); 3144 Hi : constant Uint := 3145 Expr_Value 3146 (Type_High_Bound (Etype (DSD))); 3147 3148 begin 3149 if Hi >= Lo then 3150 Ecount := Ecount + Hi - Lo + 1; 3151 end if; 3152 end; 3153 3154 -- Entry family with non-static bounds 3155 3156 else 3157 -- Record an unknown count restriction, and if the 3158 -- restriction is active, post a message or warning. 3159 3160 Check_Restriction (R, D); 3161 end if; 3162 end; 3163 end if; 3164 3165 Next (D); 3166 end loop; 3167 end Count; 3168 3169 -- Start of processing for Check_Max_Entries 3170 3171 begin 3172 Ecount := Uint_0; 3173 Count (Visible_Declarations (D)); 3174 Count (Private_Declarations (D)); 3175 3176 if Ecount > 0 then 3177 Check_Restriction (R, D, Ecount); 3178 end if; 3179 end Check_Max_Entries; 3180 3181 ---------------------- 3182 -- Check_Interfaces -- 3183 ---------------------- 3184 3185 procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is 3186 Iface : Node_Id; 3187 Iface_Typ : Entity_Id; 3188 3189 begin 3190 pragma Assert 3191 (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration)); 3192 3193 if Present (Interface_List (N)) then 3194 Set_Is_Tagged_Type (T); 3195 3196 Iface := First (Interface_List (N)); 3197 while Present (Iface) loop 3198 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 3199 3200 if not Is_Interface (Iface_Typ) then 3201 Error_Msg_NE 3202 ("(Ada 2005) & must be an interface", Iface, Iface_Typ); 3203 3204 else 3205 -- Ada 2005 (AI-251): "The declaration of a specific descendant 3206 -- of an interface type freezes the interface type" RM 13.14. 3207 3208 Freeze_Before (N, Etype (Iface)); 3209 3210 if Nkind (N) = N_Protected_Type_Declaration then 3211 3212 -- Ada 2005 (AI-345): Protected types can only implement 3213 -- limited, synchronized, or protected interfaces (note that 3214 -- the predicate Is_Limited_Interface includes synchronized 3215 -- and protected interfaces). 3216 3217 if Is_Task_Interface (Iface_Typ) then 3218 Error_Msg_N ("(Ada 2005) protected type cannot implement " 3219 & "a task interface", Iface); 3220 3221 elsif not Is_Limited_Interface (Iface_Typ) then 3222 Error_Msg_N ("(Ada 2005) protected type cannot implement " 3223 & "a non-limited interface", Iface); 3224 end if; 3225 3226 else pragma Assert (Nkind (N) = N_Task_Type_Declaration); 3227 3228 -- Ada 2005 (AI-345): Task types can only implement limited, 3229 -- synchronized, or task interfaces (note that the predicate 3230 -- Is_Limited_Interface includes synchronized and task 3231 -- interfaces). 3232 3233 if Is_Protected_Interface (Iface_Typ) then 3234 Error_Msg_N ("(Ada 2005) task type cannot implement a " & 3235 "protected interface", Iface); 3236 3237 elsif not Is_Limited_Interface (Iface_Typ) then 3238 Error_Msg_N ("(Ada 2005) task type cannot implement a " & 3239 "non-limited interface", Iface); 3240 end if; 3241 end if; 3242 end if; 3243 3244 Next (Iface); 3245 end loop; 3246 end if; 3247 3248 if not Has_Private_Declaration (T) then 3249 return; 3250 end if; 3251 3252 -- Additional checks on full-types associated with private type 3253 -- declarations. Search for the private type declaration. 3254 3255 declare 3256 Full_T_Ifaces : Elist_Id; 3257 Iface : Node_Id; 3258 Priv_T : Entity_Id; 3259 Priv_T_Ifaces : Elist_Id; 3260 3261 begin 3262 Priv_T := First_Entity (Scope (T)); 3263 loop 3264 pragma Assert (Present (Priv_T)); 3265 3266 if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then 3267 exit when Full_View (Priv_T) = T; 3268 end if; 3269 3270 Next_Entity (Priv_T); 3271 end loop; 3272 3273 -- In case of synchronized types covering interfaces the private type 3274 -- declaration must be limited. 3275 3276 if Present (Interface_List (N)) 3277 and then not Is_Limited_Type (Priv_T) 3278 then 3279 Error_Msg_Sloc := Sloc (Priv_T); 3280 Error_Msg_N ("(Ada 2005) limited type declaration expected for " & 3281 "private type#", T); 3282 end if; 3283 3284 -- RM 7.3 (7.1/2): If the full view has a partial view that is 3285 -- tagged then check RM 7.3 subsidiary rules. 3286 3287 if Is_Tagged_Type (Priv_T) 3288 and then not Error_Posted (N) 3289 then 3290 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged 3291 -- type if and only if the full type is a synchronized tagged type 3292 3293 if Is_Synchronized_Tagged_Type (Priv_T) 3294 and then not Is_Synchronized_Tagged_Type (T) 3295 then 3296 Error_Msg_N 3297 ("(Ada 2005) full view must be a synchronized tagged " & 3298 "type (RM 7.3 (7.2/2))", Priv_T); 3299 3300 elsif Is_Synchronized_Tagged_Type (T) 3301 and then not Is_Synchronized_Tagged_Type (Priv_T) 3302 then 3303 Error_Msg_N 3304 ("(Ada 2005) partial view must be a synchronized tagged " & 3305 "type (RM 7.3 (7.2/2))", T); 3306 end if; 3307 3308 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an 3309 -- interface type if and only if the full type is descendant of 3310 -- the interface type. 3311 3312 if Present (Interface_List (N)) 3313 or else (Is_Tagged_Type (Priv_T) 3314 and then Has_Interfaces 3315 (Priv_T, Use_Full_View => False)) 3316 then 3317 if Is_Tagged_Type (Priv_T) then 3318 Collect_Interfaces 3319 (Priv_T, Priv_T_Ifaces, Use_Full_View => False); 3320 end if; 3321 3322 if Is_Tagged_Type (T) then 3323 Collect_Interfaces (T, Full_T_Ifaces); 3324 end if; 3325 3326 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); 3327 3328 if Present (Iface) then 3329 Error_Msg_NE 3330 ("interface & not implemented by full type " & 3331 "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); 3332 end if; 3333 3334 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); 3335 3336 if Present (Iface) then 3337 Error_Msg_NE 3338 ("interface & not implemented by partial " & 3339 "view (RM-2005 7.3 (7.3/2))", T, Iface); 3340 end if; 3341 end if; 3342 end if; 3343 end; 3344 end Check_Interfaces; 3345 3346 -------------------------------- 3347 -- Check_Triggering_Statement -- 3348 -------------------------------- 3349 3350 procedure Check_Triggering_Statement 3351 (Trigger : Node_Id; 3352 Error_Node : Node_Id; 3353 Is_Dispatching : out Boolean) 3354 is 3355 Param : Node_Id; 3356 3357 begin 3358 Is_Dispatching := False; 3359 3360 -- It is not possible to have a dispatching trigger if we are not in 3361 -- Ada 2005 mode. 3362 3363 if Ada_Version >= Ada_2005 3364 and then Nkind (Trigger) = N_Procedure_Call_Statement 3365 and then Present (Parameter_Associations (Trigger)) 3366 then 3367 Param := First (Parameter_Associations (Trigger)); 3368 3369 if Is_Controlling_Actual (Param) 3370 and then Is_Interface (Etype (Param)) 3371 then 3372 if Is_Limited_Record (Etype (Param)) then 3373 Is_Dispatching := True; 3374 else 3375 Error_Msg_N 3376 ("dispatching operation of limited or synchronized " & 3377 "interface required (RM 9.7.2(3))!", Error_Node); 3378 end if; 3379 3380 elsif Nkind (Trigger) = N_Explicit_Dereference then 3381 Error_Msg_N 3382 ("entry call or dispatching primitive of interface required ", 3383 Trigger); 3384 end if; 3385 end if; 3386 end Check_Triggering_Statement; 3387 3388 -------------------------- 3389 -- Find_Concurrent_Spec -- 3390 -------------------------- 3391 3392 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is 3393 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id); 3394 3395 begin 3396 -- The type may have been given by an incomplete type declaration. 3397 -- Find full view now. 3398 3399 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then 3400 Spec_Id := Full_View (Spec_Id); 3401 end if; 3402 3403 return Spec_Id; 3404 end Find_Concurrent_Spec; 3405 3406 -------------------------- 3407 -- Install_Declarations -- 3408 -------------------------- 3409 3410 procedure Install_Declarations (Spec : Entity_Id) is 3411 E : Entity_Id; 3412 Prev : Entity_Id; 3413 begin 3414 E := First_Entity (Spec); 3415 while Present (E) loop 3416 Prev := Current_Entity (E); 3417 Set_Current_Entity (E); 3418 Set_Is_Immediately_Visible (E); 3419 Set_Homonym (E, Prev); 3420 Next_Entity (E); 3421 end loop; 3422 end Install_Declarations; 3423 3424 --------------------------- 3425 -- Install_Discriminants -- 3426 --------------------------- 3427 3428 procedure Install_Discriminants (E : Entity_Id) is 3429 Disc : Entity_Id; 3430 Prev : Entity_Id; 3431 begin 3432 Disc := First_Discriminant (E); 3433 while Present (Disc) loop 3434 Prev := Current_Entity (Disc); 3435 Set_Current_Entity (Disc); 3436 Set_Is_Immediately_Visible (Disc); 3437 Set_Homonym (Disc, Prev); 3438 Next_Discriminant (Disc); 3439 end loop; 3440 end Install_Discriminants; 3441 3442 ------------------------------------------ 3443 -- Push_Scope_And_Install_Discriminants -- 3444 ------------------------------------------ 3445 3446 procedure Push_Scope_And_Install_Discriminants (E : Entity_Id) is 3447 begin 3448 if Has_Discriminants (E) then 3449 Push_Scope (E); 3450 Install_Discriminants (E); 3451 end if; 3452 end Push_Scope_And_Install_Discriminants; 3453 3454 ----------------------------- 3455 -- Uninstall_Discriminants -- 3456 ----------------------------- 3457 3458 procedure Uninstall_Discriminants (E : Entity_Id) is 3459 Disc : Entity_Id; 3460 Prev : Entity_Id; 3461 Outer : Entity_Id; 3462 3463 begin 3464 Disc := First_Discriminant (E); 3465 while Present (Disc) loop 3466 if Disc /= Current_Entity (Disc) then 3467 Prev := Current_Entity (Disc); 3468 while Present (Prev) 3469 and then Present (Homonym (Prev)) 3470 and then Homonym (Prev) /= Disc 3471 loop 3472 Prev := Homonym (Prev); 3473 end loop; 3474 else 3475 Prev := Empty; 3476 end if; 3477 3478 Set_Is_Immediately_Visible (Disc, False); 3479 3480 Outer := Homonym (Disc); 3481 while Present (Outer) and then Scope (Outer) = E loop 3482 Outer := Homonym (Outer); 3483 end loop; 3484 3485 -- Reset homonym link of other entities, but do not modify link 3486 -- between entities in current scope, so that the back-end can have 3487 -- a proper count of local overloadings. 3488 3489 if No (Prev) then 3490 Set_Name_Entity_Id (Chars (Disc), Outer); 3491 3492 elsif Scope (Prev) /= Scope (Disc) then 3493 Set_Homonym (Prev, Outer); 3494 end if; 3495 3496 Next_Discriminant (Disc); 3497 end loop; 3498 end Uninstall_Discriminants; 3499 3500 ------------------------------------------- 3501 -- Uninstall_Discriminants_And_Pop_Scope -- 3502 ------------------------------------------- 3503 3504 procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id) is 3505 begin 3506 if Has_Discriminants (E) then 3507 Uninstall_Discriminants (E); 3508 Pop_Scope; 3509 end if; 3510 end Uninstall_Discriminants_And_Pop_Scope; 3511end Sem_Ch9; 3512