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