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