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 887 ("duplicate accept statement for same entry (RM 9.5.2 (15))", N); 888 889 -- Do not continue analysis of accept statement, to prevent 890 -- cascaded errors. 891 892 return; 893 end if; 894 end loop; 895 896 declare 897 P : Node_Id := N; 898 begin 899 loop 900 P := Parent (P); 901 case Nkind (P) is 902 when N_Compilation_Unit 903 | N_Task_Body 904 => 905 exit; 906 907 when N_Asynchronous_Select => 908 Error_Msg_N 909 ("accept statements are not allowed within an " 910 & "asynchronous select inner to the enclosing task body", 911 N); 912 exit; 913 914 when others => 915 null; 916 end case; 917 end loop; 918 end; 919 920 if Ekind (E) = E_Entry_Family then 921 if No (Index) then 922 Error_Msg_N ("missing entry index in accept for entry family", N); 923 else 924 Analyze_And_Resolve (Index, Entry_Index_Type (E)); 925 Apply_Range_Check (Index, Entry_Index_Type (E)); 926 end if; 927 928 elsif Present (Index) then 929 Error_Msg_N ("invalid entry index in accept for simple entry", N); 930 end if; 931 932 -- If label declarations present, analyze them. They are declared in the 933 -- enclosing task, but their enclosing scope is the entry itself, so 934 -- that goto's to the label are recognized as local to the accept. 935 936 if Present (Declarations (N)) then 937 declare 938 Decl : Node_Id; 939 Id : Entity_Id; 940 941 begin 942 Decl := First (Declarations (N)); 943 while Present (Decl) loop 944 Analyze (Decl); 945 946 pragma Assert 947 (Nkind (Decl) = N_Implicit_Label_Declaration); 948 949 Id := Defining_Identifier (Decl); 950 Set_Enclosing_Scope (Id, Entry_Nam); 951 Next (Decl); 952 end loop; 953 end; 954 end if; 955 956 -- If statements are present, they must be analyzed in the context of 957 -- the entry, so that references to formals are correctly resolved. We 958 -- also have to add the declarations that are required by the expansion 959 -- of the accept statement in this case if expansion active. 960 961 -- In the case of a select alternative of a selective accept, the 962 -- expander references the address declaration even if there is no 963 -- statement list. 964 965 -- We also need to create the renaming declarations for the local 966 -- variables that will replace references to the formals within the 967 -- accept statement. 968 969 Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam); 970 971 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value 972 -- fields on all entry formals (this loop ignores all other entities). 973 -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as 974 -- well, so that we can post accurate warnings on each accept statement 975 -- for the same entry. 976 977 E := First_Entity (Entry_Nam); 978 while Present (E) loop 979 if Is_Formal (E) then 980 Set_Never_Set_In_Source (E, True); 981 Set_Is_True_Constant (E, False); 982 Set_Current_Value (E, Empty); 983 Set_Referenced (E, False); 984 Set_Referenced_As_LHS (E, False); 985 Set_Referenced_As_Out_Parameter (E, False); 986 Set_Has_Pragma_Unreferenced (E, False); 987 end if; 988 989 Next_Entity (E); 990 end loop; 991 992 -- Analyze statements if present 993 994 if Present (Stats) then 995 Push_Scope (Entry_Nam); 996 Install_Declarations (Entry_Nam); 997 998 Set_Actual_Subtypes (N, Current_Scope); 999 1000 Analyze (Stats); 1001 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam); 1002 End_Scope; 1003 end if; 1004 1005 -- Some warning checks 1006 1007 Check_Potentially_Blocking_Operation (N); 1008 Check_References (Entry_Nam, N); 1009 Set_Entry_Accepted (Entry_Nam); 1010 end Analyze_Accept_Statement; 1011 1012 --------------------------------- 1013 -- Analyze_Asynchronous_Select -- 1014 --------------------------------- 1015 1016 procedure Analyze_Asynchronous_Select (N : Node_Id) is 1017 Is_Disp_Select : Boolean := False; 1018 Trigger : Node_Id; 1019 1020 begin 1021 Tasking_Used := True; 1022 Check_SPARK_05_Restriction ("select statement is not allowed", N); 1023 Check_Restriction (Max_Asynchronous_Select_Nesting, N); 1024 Check_Restriction (No_Select_Statements, N); 1025 1026 if Ada_Version >= Ada_2005 then 1027 Trigger := Triggering_Statement (Triggering_Alternative (N)); 1028 1029 Analyze (Trigger); 1030 1031 -- Ada 2005 (AI-345): Check for a potential dispatching select 1032 1033 Check_Triggering_Statement (Trigger, N, Is_Disp_Select); 1034 end if; 1035 1036 -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous 1037 -- select will have to duplicate the triggering statements. Postpone 1038 -- the analysis of the statements till expansion. Analyze only if the 1039 -- expander is disabled in order to catch any semantic errors. 1040 1041 if Is_Disp_Select then 1042 if not Expander_Active then 1043 Analyze_Statements (Statements (Abortable_Part (N))); 1044 Analyze (Triggering_Alternative (N)); 1045 end if; 1046 1047 -- Analyze the statements. We analyze statements in the abortable part, 1048 -- because this is the section that is executed first, and that way our 1049 -- remembering of saved values and checks is accurate. 1050 1051 else 1052 Analyze_Statements (Statements (Abortable_Part (N))); 1053 Analyze (Triggering_Alternative (N)); 1054 end if; 1055 end Analyze_Asynchronous_Select; 1056 1057 ------------------------------------ 1058 -- Analyze_Conditional_Entry_Call -- 1059 ------------------------------------ 1060 1061 procedure Analyze_Conditional_Entry_Call (N : Node_Id) is 1062 Trigger : constant Node_Id := 1063 Entry_Call_Statement (Entry_Call_Alternative (N)); 1064 Is_Disp_Select : Boolean := False; 1065 1066 begin 1067 Tasking_Used := True; 1068 Check_SPARK_05_Restriction ("select statement is not allowed", N); 1069 Check_Restriction (No_Select_Statements, N); 1070 1071 -- Ada 2005 (AI-345): The trigger may be a dispatching call 1072 1073 if Ada_Version >= Ada_2005 then 1074 Analyze (Trigger); 1075 Check_Triggering_Statement (Trigger, N, Is_Disp_Select); 1076 end if; 1077 1078 if List_Length (Else_Statements (N)) = 1 1079 and then Nkind (First (Else_Statements (N))) in N_Delay_Statement 1080 then 1081 Error_Msg_N 1082 ("suspicious form of conditional entry call??!", N); 1083 Error_Msg_N 1084 ("\`SELECT OR` may be intended rather than `SELECT ELSE`??!", N); 1085 end if; 1086 1087 -- Postpone the analysis of the statements till expansion. Analyze only 1088 -- if the expander is disabled in order to catch any semantic errors. 1089 1090 if Is_Disp_Select then 1091 if not Expander_Active then 1092 Analyze (Entry_Call_Alternative (N)); 1093 Analyze_Statements (Else_Statements (N)); 1094 end if; 1095 1096 -- Regular select analysis 1097 1098 else 1099 Analyze (Entry_Call_Alternative (N)); 1100 Analyze_Statements (Else_Statements (N)); 1101 end if; 1102 end Analyze_Conditional_Entry_Call; 1103 1104 -------------------------------- 1105 -- Analyze_Delay_Alternative -- 1106 -------------------------------- 1107 1108 procedure Analyze_Delay_Alternative (N : Node_Id) is 1109 Expr : Node_Id; 1110 Typ : Entity_Id; 1111 1112 begin 1113 Tasking_Used := True; 1114 Check_Restriction (No_Delay, N); 1115 1116 if Present (Pragmas_Before (N)) then 1117 Analyze_List (Pragmas_Before (N)); 1118 end if; 1119 1120 if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then 1121 Expr := Expression (Delay_Statement (N)); 1122 1123 -- Defer full analysis until the statement is expanded, to insure 1124 -- that generated code does not move past the guard. The delay 1125 -- expression is only evaluated if the guard is open. 1126 1127 if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then 1128 Preanalyze_And_Resolve (Expr, Standard_Duration); 1129 else 1130 Preanalyze_And_Resolve (Expr); 1131 end if; 1132 1133 Typ := First_Subtype (Etype (Expr)); 1134 1135 if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement 1136 and then not Is_RTE (Typ, RO_CA_Time) 1137 and then not Is_RTE (Typ, RO_RT_Time) 1138 then 1139 Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr); 1140 end if; 1141 1142 Check_Restriction (No_Fixed_Point, Expr); 1143 1144 else 1145 Analyze (Delay_Statement (N)); 1146 end if; 1147 1148 if Present (Condition (N)) then 1149 Analyze_And_Resolve (Condition (N), Any_Boolean); 1150 end if; 1151 1152 if Is_Non_Empty_List (Statements (N)) then 1153 Analyze_Statements (Statements (N)); 1154 end if; 1155 end Analyze_Delay_Alternative; 1156 1157 ---------------------------- 1158 -- Analyze_Delay_Relative -- 1159 ---------------------------- 1160 1161 procedure Analyze_Delay_Relative (N : Node_Id) is 1162 E : constant Node_Id := Expression (N); 1163 1164 begin 1165 Tasking_Used := True; 1166 Check_SPARK_05_Restriction ("delay statement is not allowed", N); 1167 Check_Restriction (No_Relative_Delay, N); 1168 Check_Restriction (No_Delay, N); 1169 Check_Potentially_Blocking_Operation (N); 1170 Analyze_And_Resolve (E, Standard_Duration); 1171 Check_Restriction (No_Fixed_Point, E); 1172 1173 -- In SPARK mode the relative delay statement introduces an implicit 1174 -- dependency on the Ada.Real_Time.Clock_Time abstract state, so we must 1175 -- force the loading of the Ada.Real_Time package. 1176 1177 if GNATprove_Mode then 1178 SPARK_Implicit_Load (RO_RT_Time); 1179 end if; 1180 end Analyze_Delay_Relative; 1181 1182 ------------------------- 1183 -- Analyze_Delay_Until -- 1184 ------------------------- 1185 1186 procedure Analyze_Delay_Until (N : Node_Id) is 1187 E : constant Node_Id := Expression (N); 1188 Typ : Entity_Id; 1189 1190 begin 1191 Tasking_Used := True; 1192 Check_SPARK_05_Restriction ("delay statement is not allowed", N); 1193 Check_Restriction (No_Delay, N); 1194 Check_Potentially_Blocking_Operation (N); 1195 Analyze_And_Resolve (E); 1196 Typ := First_Subtype (Etype (E)); 1197 1198 if not Is_RTE (Typ, RO_CA_Time) and then 1199 not Is_RTE (Typ, RO_RT_Time) 1200 then 1201 Error_Msg_N ("expect Time types for `DELAY UNTIL`", E); 1202 end if; 1203 end Analyze_Delay_Until; 1204 1205 ------------------------ 1206 -- Analyze_Entry_Body -- 1207 ------------------------ 1208 1209 procedure Analyze_Entry_Body (N : Node_Id) is 1210 Id : constant Entity_Id := Defining_Identifier (N); 1211 Decls : constant List_Id := Declarations (N); 1212 Stats : constant Node_Id := Handled_Statement_Sequence (N); 1213 Formals : constant Node_Id := Entry_Body_Formal_Part (N); 1214 P_Type : constant Entity_Id := Current_Scope; 1215 E : Entity_Id; 1216 Entry_Name : Entity_Id; 1217 1218 begin 1219 -- An entry body freezes the contract of the nearest enclosing package 1220 -- body and all other contracts encountered in the same declarative part 1221 -- up to and excluding the entry body. This ensures that any annotations 1222 -- referenced by the contract of an entry or subprogram body declared 1223 -- within the current protected body are available. 1224 1225 Freeze_Previous_Contracts (N); 1226 1227 Tasking_Used := True; 1228 1229 -- Entry_Name is initialized to Any_Id. It should get reset to the 1230 -- matching entry entity. An error is signalled if it is not reset. 1231 1232 Entry_Name := Any_Id; 1233 1234 Analyze (Formals); 1235 1236 if Present (Entry_Index_Specification (Formals)) then 1237 Set_Ekind (Id, E_Entry_Family); 1238 else 1239 Set_Ekind (Id, E_Entry); 1240 end if; 1241 1242 Set_Etype (Id, Standard_Void_Type); 1243 Set_Scope (Id, Current_Scope); 1244 Set_Accept_Address (Id, New_Elmt_List); 1245 1246 -- Set the SPARK_Mode from the current context (may be overwritten later 1247 -- with an explicit pragma). 1248 1249 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 1250 Set_SPARK_Pragma_Inherited (Id); 1251 1252 -- Analyze any aspect specifications that appear on the entry body 1253 1254 if Has_Aspects (N) then 1255 Analyze_Aspects_On_Subprogram_Body_Or_Stub (N); 1256 end if; 1257 1258 E := First_Entity (P_Type); 1259 while Present (E) loop 1260 if Chars (E) = Chars (Id) 1261 and then (Ekind (E) = Ekind (Id)) 1262 and then Type_Conformant (Id, E) 1263 then 1264 Entry_Name := E; 1265 Set_Convention (Id, Convention (E)); 1266 Set_Corresponding_Body (Parent (E), Id); 1267 Check_Fully_Conformant (Id, E, N); 1268 1269 if Ekind (Id) = E_Entry_Family then 1270 if not Fully_Conformant_Discrete_Subtypes ( 1271 Discrete_Subtype_Definition (Parent (E)), 1272 Discrete_Subtype_Definition 1273 (Entry_Index_Specification (Formals))) 1274 then 1275 Error_Msg_N 1276 ("index not fully conformant with previous declaration", 1277 Discrete_Subtype_Definition 1278 (Entry_Index_Specification (Formals))); 1279 1280 else 1281 -- The elaboration of the entry body does not recompute the 1282 -- bounds of the index, which may have side effects. Inherit 1283 -- the bounds from the entry declaration. This is critical 1284 -- if the entry has a per-object constraint. If a bound is 1285 -- given by a discriminant, it must be reanalyzed in order 1286 -- to capture the discriminal of the current entry, rather 1287 -- than that of the protected type. 1288 1289 declare 1290 Index_Spec : constant Node_Id := 1291 Entry_Index_Specification (Formals); 1292 1293 Def : constant Node_Id := 1294 New_Copy_Tree 1295 (Discrete_Subtype_Definition (Parent (E))); 1296 1297 begin 1298 if Nkind 1299 (Original_Node 1300 (Discrete_Subtype_Definition (Index_Spec))) = N_Range 1301 then 1302 Set_Etype (Def, Empty); 1303 Set_Analyzed (Def, False); 1304 1305 -- Keep the original subtree to ensure a properly 1306 -- formed tree (e.g. for ASIS use). 1307 1308 Rewrite 1309 (Discrete_Subtype_Definition (Index_Spec), Def); 1310 1311 Set_Analyzed (Low_Bound (Def), False); 1312 Set_Analyzed (High_Bound (Def), False); 1313 1314 if Denotes_Discriminant (Low_Bound (Def)) then 1315 Set_Entity (Low_Bound (Def), Empty); 1316 end if; 1317 1318 if Denotes_Discriminant (High_Bound (Def)) then 1319 Set_Entity (High_Bound (Def), Empty); 1320 end if; 1321 1322 Analyze (Def); 1323 Make_Index (Def, Index_Spec); 1324 Set_Etype 1325 (Defining_Identifier (Index_Spec), Etype (Def)); 1326 end if; 1327 end; 1328 end if; 1329 end if; 1330 1331 exit; 1332 end if; 1333 1334 Next_Entity (E); 1335 end loop; 1336 1337 if Entry_Name = Any_Id then 1338 Error_Msg_N ("no entry declaration matches entry body", N); 1339 return; 1340 1341 elsif Has_Completion (Entry_Name) then 1342 Error_Msg_N ("duplicate entry body", N); 1343 return; 1344 1345 else 1346 Set_Has_Completion (Entry_Name); 1347 Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False); 1348 Style.Check_Identifier (Id, Entry_Name); 1349 end if; 1350 1351 Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); 1352 Push_Scope (Entry_Name); 1353 1354 Install_Declarations (Entry_Name); 1355 Set_Actual_Subtypes (N, Current_Scope); 1356 1357 -- The entity for the protected subprogram corresponding to the entry 1358 -- has been created. We retain the name of this entity in the entry 1359 -- body, for use when the corresponding subprogram body is created. 1360 -- Note that entry bodies have no Corresponding_Spec, and there is no 1361 -- easy link back in the tree between the entry body and the entity for 1362 -- the entry itself, which is why we must propagate some attributes 1363 -- explicitly from spec to body. 1364 1365 Set_Protected_Body_Subprogram 1366 (Id, Protected_Body_Subprogram (Entry_Name)); 1367 1368 Set_Entry_Parameters_Type 1369 (Id, Entry_Parameters_Type (Entry_Name)); 1370 1371 -- Add a declaration for the Protection object, renaming declarations 1372 -- for the discriminals and privals and finally a declaration for the 1373 -- entry family index (if applicable). 1374 1375 if Expander_Active 1376 and then Is_Protected_Type (P_Type) 1377 then 1378 Install_Private_Data_Declarations 1379 (Sloc (N), Entry_Name, P_Type, N, Decls); 1380 end if; 1381 1382 if Present (Decls) then 1383 Analyze_Declarations (Decls); 1384 Inspect_Deferred_Constant_Completion (Decls); 1385 end if; 1386 1387 -- Process the contract of the subprogram body after all declarations 1388 -- have been analyzed. This ensures that any contract-related pragmas 1389 -- are available through the N_Contract node of the body. 1390 1391 Analyze_Entry_Or_Subprogram_Body_Contract (Id); 1392 1393 if Present (Stats) then 1394 Analyze (Stats); 1395 end if; 1396 1397 -- Check for unreferenced variables etc. Before the Check_References 1398 -- call, we transfer Never_Set_In_Source and Referenced flags from 1399 -- parameters in the spec to the corresponding entities in the body, 1400 -- since we want the warnings on the body entities. Note that we do not 1401 -- have to transfer Referenced_As_LHS, since that flag can only be set 1402 -- for simple variables, but we include Has_Pragma_Unreferenced, 1403 -- which may have been specified for a formal in the body. 1404 1405 -- At the same time, we set the flags on the spec entities to suppress 1406 -- any warnings on the spec formals, since we also scan the spec. 1407 -- Finally, we propagate the Entry_Component attribute to the body 1408 -- formals, for use in the renaming declarations created later for the 1409 -- formals (see exp_ch9.Add_Formal_Renamings). 1410 1411 declare 1412 E1 : Entity_Id; 1413 E2 : Entity_Id; 1414 1415 begin 1416 E1 := First_Entity (Entry_Name); 1417 while Present (E1) loop 1418 E2 := First_Entity (Id); 1419 while Present (E2) loop 1420 exit when Chars (E1) = Chars (E2); 1421 Next_Entity (E2); 1422 end loop; 1423 1424 -- If no matching body entity, then we already had a detected 1425 -- error of some kind, so just don't worry about these warnings. 1426 1427 if No (E2) then 1428 goto Continue; 1429 end if; 1430 1431 if Ekind (E1) = E_Out_Parameter then 1432 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1)); 1433 Set_Never_Set_In_Source (E1, False); 1434 end if; 1435 1436 Set_Referenced (E2, Referenced (E1)); 1437 Set_Referenced (E1); 1438 Set_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (E1)); 1439 Set_Entry_Component (E2, Entry_Component (E1)); 1440 1441 <<Continue>> 1442 Next_Entity (E1); 1443 end loop; 1444 1445 Check_References (Id); 1446 end; 1447 1448 -- We still need to check references for the spec, since objects 1449 -- declared in the body are chained (in the First_Entity sense) to 1450 -- the spec rather than the body in the case of entries. 1451 1452 Check_References (Entry_Name); 1453 1454 -- Process the end label, and terminate the scope 1455 1456 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); 1457 Update_Use_Clause_Chain; 1458 End_Scope; 1459 1460 -- If this is an entry family, remove the loop created to provide 1461 -- a scope for the entry index. 1462 1463 if Ekind (Id) = E_Entry_Family 1464 and then Present (Entry_Index_Specification (Formals)) 1465 then 1466 End_Scope; 1467 end if; 1468 end Analyze_Entry_Body; 1469 1470 ------------------------------------ 1471 -- Analyze_Entry_Body_Formal_Part -- 1472 ------------------------------------ 1473 1474 procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is 1475 Id : constant Entity_Id := Defining_Identifier (Parent (N)); 1476 Index : constant Node_Id := Entry_Index_Specification (N); 1477 Formals : constant List_Id := Parameter_Specifications (N); 1478 1479 begin 1480 Tasking_Used := True; 1481 1482 if Present (Index) then 1483 Analyze (Index); 1484 1485 -- The entry index functions like a loop variable, thus it is known 1486 -- to have a valid value. 1487 1488 Set_Is_Known_Valid (Defining_Identifier (Index)); 1489 end if; 1490 1491 if Present (Formals) then 1492 Set_Scope (Id, Current_Scope); 1493 Push_Scope (Id); 1494 Process_Formals (Formals, Parent (N)); 1495 End_Scope; 1496 end if; 1497 end Analyze_Entry_Body_Formal_Part; 1498 1499 ------------------------------------ 1500 -- Analyze_Entry_Call_Alternative -- 1501 ------------------------------------ 1502 1503 procedure Analyze_Entry_Call_Alternative (N : Node_Id) is 1504 Call : constant Node_Id := Entry_Call_Statement (N); 1505 1506 begin 1507 Tasking_Used := True; 1508 Check_SPARK_05_Restriction ("entry call is not allowed", N); 1509 1510 if Present (Pragmas_Before (N)) then 1511 Analyze_List (Pragmas_Before (N)); 1512 end if; 1513 1514 if Nkind (Call) = N_Attribute_Reference then 1515 1516 -- Possibly a stream attribute, but definitely illegal. Other 1517 -- illegalities, such as procedure calls, are diagnosed after 1518 -- resolution. 1519 1520 Error_Msg_N ("entry call alternative requires an entry call", Call); 1521 return; 1522 end if; 1523 1524 Analyze (Call); 1525 1526 -- An indirect call in this context is illegal. A procedure call that 1527 -- does not involve a renaming of an entry is illegal as well, but this 1528 -- and other semantic errors are caught during resolution. 1529 1530 if Nkind (Call) = N_Explicit_Dereference then 1531 Error_Msg_N 1532 ("entry call or dispatching primitive of interface required ", N); 1533 end if; 1534 1535 if Is_Non_Empty_List (Statements (N)) then 1536 Analyze_Statements (Statements (N)); 1537 end if; 1538 end Analyze_Entry_Call_Alternative; 1539 1540 ------------------------------- 1541 -- Analyze_Entry_Declaration -- 1542 ------------------------------- 1543 1544 procedure Analyze_Entry_Declaration (N : Node_Id) is 1545 D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); 1546 Def_Id : constant Entity_Id := Defining_Identifier (N); 1547 Formals : constant List_Id := Parameter_Specifications (N); 1548 1549 begin 1550 Generate_Definition (Def_Id); 1551 1552 Tasking_Used := True; 1553 1554 -- Case of no discrete subtype definition 1555 1556 if No (D_Sdef) then 1557 Set_Ekind (Def_Id, E_Entry); 1558 1559 -- Processing for discrete subtype definition present 1560 1561 else 1562 Enter_Name (Def_Id); 1563 Set_Ekind (Def_Id, E_Entry_Family); 1564 Analyze (D_Sdef); 1565 Make_Index (D_Sdef, N, Def_Id); 1566 1567 -- Check subtype with predicate in entry family 1568 1569 Bad_Predicated_Subtype_Use 1570 ("subtype& has predicate, not allowed in entry family", 1571 D_Sdef, Etype (D_Sdef)); 1572 1573 -- Check entry family static bounds outside allowed limits 1574 1575 -- Note: originally this check was not performed here, but in that 1576 -- case the check happens deep in the expander, and the message is 1577 -- posted at the wrong location, and omitted in -gnatc mode. 1578 -- If the type of the entry index is a generic formal, no check 1579 -- is possible. In an instance, the check is not static and a run- 1580 -- time exception will be raised if the bounds are unreasonable. 1581 1582 declare 1583 PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index); 1584 LB : constant Uint := Expr_Value (Type_Low_Bound (PEI)); 1585 UB : constant Uint := Expr_Value (Type_High_Bound (PEI)); 1586 1587 LBR : Node_Id; 1588 UBR : Node_Id; 1589 1590 begin 1591 1592 -- No bounds checking if the type is generic or if previous error. 1593 -- In an instance the check is dynamic. 1594 1595 if Is_Generic_Type (Etype (D_Sdef)) 1596 or else In_Instance 1597 or else Error_Posted (D_Sdef) 1598 then 1599 goto Skip_LB; 1600 1601 elsif Nkind (D_Sdef) = N_Range then 1602 LBR := Low_Bound (D_Sdef); 1603 1604 elsif Is_Entity_Name (D_Sdef) 1605 and then Is_Type (Entity (D_Sdef)) 1606 then 1607 LBR := Type_Low_Bound (Entity (D_Sdef)); 1608 1609 else 1610 goto Skip_LB; 1611 end if; 1612 1613 if Is_OK_Static_Expression (LBR) 1614 and then Expr_Value (LBR) < LB 1615 then 1616 Error_Msg_Uint_1 := LB; 1617 Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef); 1618 end if; 1619 1620 <<Skip_LB>> 1621 if Is_Generic_Type (Etype (D_Sdef)) 1622 or else In_Instance 1623 or else Error_Posted (D_Sdef) 1624 then 1625 goto Skip_UB; 1626 1627 elsif Nkind (D_Sdef) = N_Range then 1628 UBR := High_Bound (D_Sdef); 1629 1630 elsif Is_Entity_Name (D_Sdef) 1631 and then Is_Type (Entity (D_Sdef)) 1632 then 1633 UBR := Type_High_Bound (Entity (D_Sdef)); 1634 1635 else 1636 goto Skip_UB; 1637 end if; 1638 1639 if Is_OK_Static_Expression (UBR) 1640 and then Expr_Value (UBR) > UB 1641 then 1642 Error_Msg_Uint_1 := UB; 1643 Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef); 1644 end if; 1645 1646 <<Skip_UB>> 1647 null; 1648 end; 1649 end if; 1650 1651 -- Decorate Def_Id 1652 1653 Set_Etype (Def_Id, Standard_Void_Type); 1654 Set_Convention (Def_Id, Convention_Entry); 1655 Set_Accept_Address (Def_Id, New_Elmt_List); 1656 1657 -- Set the SPARK_Mode from the current context (may be overwritten later 1658 -- with an explicit pragma). Task entries are excluded because they are 1659 -- not completed by entry bodies. 1660 1661 if Ekind (Current_Scope) = E_Protected_Type then 1662 Set_SPARK_Pragma (Def_Id, SPARK_Mode_Pragma); 1663 Set_SPARK_Pragma_Inherited (Def_Id); 1664 end if; 1665 1666 -- Preserve relevant elaboration-related attributes of the context which 1667 -- are no longer available or very expensive to recompute once analysis, 1668 -- resolution, and expansion are over. 1669 1670 Mark_Elaboration_Attributes 1671 (N_Id => Def_Id, 1672 Checks => True, 1673 Warnings => True); 1674 1675 -- Process formals 1676 1677 if Present (Formals) then 1678 Set_Scope (Def_Id, Current_Scope); 1679 Push_Scope (Def_Id); 1680 Process_Formals (Formals, N); 1681 Create_Extra_Formals (Def_Id); 1682 End_Scope; 1683 end if; 1684 1685 if Ekind (Def_Id) = E_Entry then 1686 New_Overloaded_Entity (Def_Id); 1687 end if; 1688 1689 Generate_Reference_To_Formals (Def_Id); 1690 1691 if Has_Aspects (N) then 1692 Analyze_Aspect_Specifications (N, Def_Id); 1693 end if; 1694 end Analyze_Entry_Declaration; 1695 1696 --------------------------------------- 1697 -- Analyze_Entry_Index_Specification -- 1698 --------------------------------------- 1699 1700 -- The Defining_Identifier of the entry index specification is local to the 1701 -- entry body, but it must be available in the entry barrier which is 1702 -- evaluated outside of the entry body. The index is eventually renamed as 1703 -- a run-time object, so its visibility is strictly a front-end concern. In 1704 -- order to make it available to the barrier, we create an additional 1705 -- scope, as for a loop, whose only declaration is the index name. This 1706 -- loop is not attached to the tree and does not appear as an entity local 1707 -- to the protected type, so its existence need only be known to routines 1708 -- that process entry families. 1709 1710 procedure Analyze_Entry_Index_Specification (N : Node_Id) is 1711 Iden : constant Node_Id := Defining_Identifier (N); 1712 Def : constant Node_Id := Discrete_Subtype_Definition (N); 1713 Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); 1714 1715 begin 1716 Tasking_Used := True; 1717 Analyze (Def); 1718 1719 -- There is no elaboration of the entry index specification. Therefore, 1720 -- if the index is a range, it is not resolved and expanded, but the 1721 -- bounds are inherited from the entry declaration, and reanalyzed. 1722 -- See Analyze_Entry_Body. 1723 1724 if Nkind (Def) /= N_Range then 1725 Make_Index (Def, N); 1726 end if; 1727 1728 Set_Ekind (Loop_Id, E_Loop); 1729 Set_Scope (Loop_Id, Current_Scope); 1730 Push_Scope (Loop_Id); 1731 Enter_Name (Iden); 1732 Set_Ekind (Iden, E_Entry_Index_Parameter); 1733 Set_Etype (Iden, Etype (Def)); 1734 end Analyze_Entry_Index_Specification; 1735 1736 ---------------------------- 1737 -- Analyze_Protected_Body -- 1738 ---------------------------- 1739 1740 procedure Analyze_Protected_Body (N : Node_Id) is 1741 Body_Id : constant Entity_Id := Defining_Identifier (N); 1742 Last_E : Entity_Id; 1743 1744 Spec_Id : Entity_Id; 1745 -- This is initially the entity of the protected object or protected 1746 -- type involved, but is replaced by the protected type always in the 1747 -- case of a single protected declaration, since this is the proper 1748 -- scope to be used. 1749 1750 Ref_Id : Entity_Id; 1751 -- This is the entity of the protected object or protected type 1752 -- involved, and is the entity used for cross-reference purposes (it 1753 -- differs from Spec_Id in the case of a single protected object, since 1754 -- Spec_Id is set to the protected type in this case). 1755 1756 function Lock_Free_Disabled return Boolean; 1757 -- This routine returns False if the protected object has a Lock_Free 1758 -- aspect specification or a Lock_Free pragma that turns off the 1759 -- lock-free implementation (e.g. whose expression is False). 1760 1761 ------------------------ 1762 -- Lock_Free_Disabled -- 1763 ------------------------ 1764 1765 function Lock_Free_Disabled return Boolean is 1766 Ritem : constant Node_Id := 1767 Get_Rep_Item 1768 (Spec_Id, Name_Lock_Free, Check_Parents => False); 1769 1770 begin 1771 if Present (Ritem) then 1772 1773 -- Pragma with one argument 1774 1775 if Nkind (Ritem) = N_Pragma 1776 and then Present (Pragma_Argument_Associations (Ritem)) 1777 then 1778 return 1779 Is_False 1780 (Static_Boolean 1781 (Expression 1782 (First (Pragma_Argument_Associations (Ritem))))); 1783 1784 -- Aspect Specification with expression present 1785 1786 elsif Nkind (Ritem) = N_Aspect_Specification 1787 and then Present (Expression (Ritem)) 1788 then 1789 return Is_False (Static_Boolean (Expression (Ritem))); 1790 1791 -- Otherwise, return False 1792 1793 else 1794 return False; 1795 end if; 1796 end if; 1797 1798 return False; 1799 end Lock_Free_Disabled; 1800 1801 -- Start of processing for Analyze_Protected_Body 1802 1803 begin 1804 -- A protected body freezes the contract of the nearest enclosing 1805 -- package body and all other contracts encountered in the same 1806 -- declarative part up to and excluding the protected body. This 1807 -- ensures that any annotations referenced by the contract of an 1808 -- entry or subprogram body declared within the current protected 1809 -- body are available. 1810 1811 Freeze_Previous_Contracts (N); 1812 1813 Tasking_Used := True; 1814 Set_Ekind (Body_Id, E_Protected_Body); 1815 Set_Etype (Body_Id, Standard_Void_Type); 1816 Spec_Id := Find_Concurrent_Spec (Body_Id); 1817 1818 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then 1819 null; 1820 1821 elsif Present (Spec_Id) 1822 and then Ekind (Etype (Spec_Id)) = E_Protected_Type 1823 and then not Comes_From_Source (Etype (Spec_Id)) 1824 then 1825 null; 1826 1827 else 1828 Error_Msg_N ("missing specification for protected body", Body_Id); 1829 return; 1830 end if; 1831 1832 Ref_Id := Spec_Id; 1833 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); 1834 Style.Check_Identifier (Body_Id, Spec_Id); 1835 1836 -- The declarations are always attached to the type 1837 1838 if Ekind (Spec_Id) /= E_Protected_Type then 1839 Spec_Id := Etype (Spec_Id); 1840 end if; 1841 1842 if Has_Aspects (N) then 1843 Analyze_Aspect_Specifications (N, Body_Id); 1844 end if; 1845 1846 Push_Scope (Spec_Id); 1847 Set_Corresponding_Spec (N, Spec_Id); 1848 Set_Corresponding_Body (Parent (Spec_Id), Body_Id); 1849 Set_Has_Completion (Spec_Id); 1850 Install_Declarations (Spec_Id); 1851 Expand_Protected_Body_Declarations (N, Spec_Id); 1852 Last_E := Last_Entity (Spec_Id); 1853 1854 Analyze_Declarations (Declarations (N)); 1855 1856 -- For visibility purposes, all entities in the body are private. Set 1857 -- First_Private_Entity accordingly, if there was no private part in the 1858 -- protected declaration. 1859 1860 if No (First_Private_Entity (Spec_Id)) then 1861 if Present (Last_E) then 1862 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); 1863 else 1864 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); 1865 end if; 1866 end if; 1867 1868 Check_Completion (Body_Id); 1869 Check_References (Spec_Id); 1870 Process_End_Label (N, 't', Ref_Id); 1871 Update_Use_Clause_Chain; 1872 End_Scope; 1873 1874 -- When a Lock_Free aspect specification/pragma forces the lock-free 1875 -- implementation, verify the protected body meets all the restrictions, 1876 -- otherwise Allows_Lock_Free_Implementation issues an error message. 1877 1878 if Uses_Lock_Free (Spec_Id) then 1879 if not Allows_Lock_Free_Implementation (N, True) then 1880 return; 1881 end if; 1882 1883 -- In other cases, if there is no aspect specification/pragma that 1884 -- disables the lock-free implementation, check both the protected 1885 -- declaration and body satisfy the lock-free restrictions. 1886 1887 elsif not Lock_Free_Disabled 1888 and then Allows_Lock_Free_Implementation (Parent (Spec_Id)) 1889 and then Allows_Lock_Free_Implementation (N) 1890 then 1891 Set_Uses_Lock_Free (Spec_Id); 1892 end if; 1893 end Analyze_Protected_Body; 1894 1895 ---------------------------------- 1896 -- Analyze_Protected_Definition -- 1897 ---------------------------------- 1898 1899 procedure Analyze_Protected_Definition (N : Node_Id) is 1900 procedure Undelay_Itypes (T : Entity_Id); 1901 -- Itypes created for the private components of a protected type 1902 -- do not receive freeze nodes, because there is no scope in which 1903 -- they can be elaborated, and they can depend on discriminants of 1904 -- the enclosed protected type. Given that the components can be 1905 -- composite types with inner components, we traverse recursively 1906 -- the private components of the protected type, and indicate that 1907 -- all itypes within are frozen. This ensures that no freeze nodes 1908 -- will be generated for them. In the case of itypes that are access 1909 -- types we need to complete their representation by calling layout, 1910 -- which would otherwise be invoked when freezing a type. 1911 -- 1912 -- On the other hand, components of the corresponding record are 1913 -- frozen (or receive itype references) as for other records. 1914 1915 -------------------- 1916 -- Undelay_Itypes -- 1917 -------------------- 1918 1919 procedure Undelay_Itypes (T : Entity_Id) is 1920 Comp : Entity_Id; 1921 1922 begin 1923 if Is_Protected_Type (T) then 1924 Comp := First_Private_Entity (T); 1925 elsif Is_Record_Type (T) then 1926 Comp := First_Entity (T); 1927 else 1928 return; 1929 end if; 1930 1931 while Present (Comp) loop 1932 if Is_Type (Comp) and then Is_Itype (Comp) then 1933 Set_Has_Delayed_Freeze (Comp, False); 1934 Set_Is_Frozen (Comp); 1935 1936 if Is_Access_Type (Comp) then 1937 Layout_Type (Comp); 1938 end if; 1939 1940 if Is_Record_Type (Comp) or else Is_Protected_Type (Comp) then 1941 Undelay_Itypes (Comp); 1942 end if; 1943 end if; 1944 1945 Next_Entity (Comp); 1946 end loop; 1947 end Undelay_Itypes; 1948 1949 -- Local variables 1950 1951 Prot_Typ : constant Entity_Id := Current_Scope; 1952 Item_Id : Entity_Id; 1953 Last_Id : Entity_Id; 1954 1955 -- Start of processing for Analyze_Protected_Definition 1956 1957 begin 1958 Tasking_Used := True; 1959 Check_SPARK_05_Restriction ("protected definition is not allowed", N); 1960 Analyze_Declarations (Visible_Declarations (N)); 1961 1962 if Present (Private_Declarations (N)) 1963 and then not Is_Empty_List (Private_Declarations (N)) 1964 then 1965 Last_Id := Last_Entity (Prot_Typ); 1966 Analyze_Declarations (Private_Declarations (N)); 1967 1968 if Present (Last_Id) then 1969 Set_First_Private_Entity (Prot_Typ, Next_Entity (Last_Id)); 1970 else 1971 Set_First_Private_Entity (Prot_Typ, First_Entity (Prot_Typ)); 1972 end if; 1973 end if; 1974 1975 Item_Id := First_Entity (Prot_Typ); 1976 while Present (Item_Id) loop 1977 if Ekind_In (Item_Id, E_Function, E_Procedure) then 1978 Set_Convention (Item_Id, Convention_Protected); 1979 else 1980 Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id)); 1981 1982 if Chars (Item_Id) /= Name_uParent 1983 and then Needs_Finalization (Etype (Item_Id)) 1984 then 1985 Set_Has_Controlled_Component (Prot_Typ); 1986 end if; 1987 end if; 1988 1989 Next_Entity (Item_Id); 1990 end loop; 1991 1992 Undelay_Itypes (Prot_Typ); 1993 1994 Check_Max_Entries (N, Max_Protected_Entries); 1995 Process_End_Label (N, 'e', Prot_Typ); 1996 end Analyze_Protected_Definition; 1997 1998 ---------------------------------------- 1999 -- Analyze_Protected_Type_Declaration -- 2000 ---------------------------------------- 2001 2002 procedure Analyze_Protected_Type_Declaration (N : Node_Id) is 2003 Def_Id : constant Entity_Id := Defining_Identifier (N); 2004 E : Entity_Id; 2005 T : Entity_Id; 2006 2007 begin 2008 if No_Run_Time_Mode then 2009 Error_Msg_CRT ("protected type", N); 2010 2011 if Has_Aspects (N) then 2012 Analyze_Aspect_Specifications (N, Def_Id); 2013 end if; 2014 2015 return; 2016 end if; 2017 2018 Tasking_Used := True; 2019 Check_Restriction (No_Protected_Types, N); 2020 2021 T := Find_Type_Name (N); 2022 2023 -- In the case of an incomplete type, use the full view, unless it's not 2024 -- present (as can occur for an incomplete view from a limited with). 2025 2026 if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then 2027 T := Full_View (T); 2028 Set_Completion_Referenced (T); 2029 end if; 2030 2031 Set_Ekind (T, E_Protected_Type); 2032 Set_Is_First_Subtype (T); 2033 Init_Size_Align (T); 2034 Set_Etype (T, T); 2035 Set_Has_Delayed_Freeze (T); 2036 Set_Stored_Constraint (T, No_Elist); 2037 2038 -- Mark this type as a protected type for the sake of restrictions, 2039 -- unless the protected type is declared in a private part of a package 2040 -- of the runtime. With this exception, the Suspension_Object from 2041 -- Ada.Synchronous_Task_Control can be implemented using a protected 2042 -- object without triggering violations of No_Local_Protected_Objects 2043 -- when the user locally declares such an object. This may look like a 2044 -- trick, but the user doesn't have to know how Suspension_Object is 2045 -- implemented. 2046 2047 if In_Private_Part (Current_Scope) 2048 and then Is_Internal_Unit (Current_Sem_Unit) 2049 then 2050 Set_Has_Protected (T, False); 2051 else 2052 Set_Has_Protected (T); 2053 end if; 2054 2055 -- Set the SPARK_Mode from the current context (may be overwritten later 2056 -- with an explicit pragma). 2057 2058 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 2059 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); 2060 Set_SPARK_Pragma_Inherited (T); 2061 Set_SPARK_Aux_Pragma_Inherited (T); 2062 2063 Push_Scope (T); 2064 2065 if Ada_Version >= Ada_2005 then 2066 Check_Interfaces (N, T); 2067 end if; 2068 2069 if Present (Discriminant_Specifications (N)) then 2070 if Has_Discriminants (T) then 2071 2072 -- Install discriminants. Also, verify conformance of 2073 -- discriminants of previous and current view. ??? 2074 2075 Install_Declarations (T); 2076 else 2077 Process_Discriminants (N); 2078 end if; 2079 end if; 2080 2081 Set_Is_Constrained (T, not Has_Discriminants (T)); 2082 2083 -- If aspects are present, analyze them now. They can make references to 2084 -- the discriminants of the type, but not to any components. 2085 2086 if Has_Aspects (N) then 2087 2088 -- The protected type is the full view of a private type. Analyze the 2089 -- aspects with the entity of the private type to ensure that after 2090 -- both views are exchanged, the aspect are actually associated with 2091 -- the full view. 2092 2093 if T /= Def_Id and then Is_Private_Type (Def_Id) then 2094 Analyze_Aspect_Specifications (N, T); 2095 else 2096 Analyze_Aspect_Specifications (N, Def_Id); 2097 end if; 2098 end if; 2099 2100 Analyze (Protected_Definition (N)); 2101 2102 -- In the case where the protected type is declared at a nested level 2103 -- and the No_Local_Protected_Objects restriction applies, issue a 2104 -- warning that objects of the type will violate the restriction. 2105 2106 if Restriction_Check_Required (No_Local_Protected_Objects) 2107 and then not Is_Library_Level_Entity (T) 2108 and then Comes_From_Source (T) 2109 then 2110 Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); 2111 2112 if Error_Msg_Sloc = No_Location then 2113 Error_Msg_N 2114 ("objects of this type will violate " & 2115 "`No_Local_Protected_Objects`??", N); 2116 else 2117 Error_Msg_N 2118 ("objects of this type will violate " & 2119 "`No_Local_Protected_Objects`#??", N); 2120 end if; 2121 end if; 2122 2123 -- Protected types with entries are controlled (because of the 2124 -- Protection component if nothing else), same for any protected type 2125 -- with interrupt handlers. Note that we need to analyze the protected 2126 -- definition to set Has_Entries and such. 2127 2128 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False 2129 or else Number_Entries (T) > 1) 2130 and then not Restricted_Profile 2131 and then 2132 (Has_Entries (T) 2133 or else Has_Interrupt_Handler (T) 2134 or else Has_Attach_Handler (T)) 2135 then 2136 Set_Has_Controlled_Component (T, True); 2137 end if; 2138 2139 -- The Ekind of components is E_Void during analysis to detect illegal 2140 -- uses. Now it can be set correctly. 2141 2142 E := First_Entity (Current_Scope); 2143 while Present (E) loop 2144 if Ekind (E) = E_Void then 2145 Set_Ekind (E, E_Component); 2146 Init_Component_Location (E); 2147 end if; 2148 2149 Next_Entity (E); 2150 end loop; 2151 2152 End_Scope; 2153 2154 -- When a Lock_Free aspect forces the lock-free implementation, check N 2155 -- meets all the lock-free restrictions. Otherwise, an error message is 2156 -- issued by Allows_Lock_Free_Implementation. 2157 2158 if Uses_Lock_Free (Defining_Identifier (N)) then 2159 2160 -- Complain when there is an explicit aspect/pragma Priority (or 2161 -- Interrupt_Priority) while the lock-free implementation is forced 2162 -- by an aspect/pragma. 2163 2164 declare 2165 Id : constant Entity_Id := Defining_Identifier (Original_Node (N)); 2166 -- The warning must be issued on the original identifier in order 2167 -- to deal properly with the case of a single protected object. 2168 2169 Prio_Item : constant Node_Id := 2170 Get_Rep_Item (Def_Id, Name_Priority, False); 2171 2172 begin 2173 if Present (Prio_Item) then 2174 2175 -- Aspect case 2176 2177 if Nkind (Prio_Item) = N_Aspect_Specification 2178 or else From_Aspect_Specification (Prio_Item) 2179 then 2180 Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); 2181 Error_Msg_NE 2182 ("aspect% for & has no effect when Lock_Free given??", 2183 Prio_Item, Id); 2184 2185 -- Pragma case 2186 2187 else 2188 Error_Msg_Name_1 := Pragma_Name (Prio_Item); 2189 Error_Msg_NE 2190 ("pragma% for & has no effect when Lock_Free given??", 2191 Prio_Item, Id); 2192 end if; 2193 end if; 2194 end; 2195 2196 if not Allows_Lock_Free_Implementation (N, Lock_Free_Given => True) 2197 then 2198 return; 2199 end if; 2200 end if; 2201 2202 -- If the Attach_Handler aspect is specified or the Interrupt_Handler 2203 -- aspect is True, then the initial ceiling priority must be in the 2204 -- range of System.Interrupt_Priority. It is therefore recommanded 2205 -- to use the Interrupt_Priority aspect instead of the Priority aspect. 2206 2207 if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then 2208 declare 2209 Prio_Item : constant Node_Id := 2210 Get_Rep_Item (Def_Id, Name_Priority, False); 2211 2212 begin 2213 if Present (Prio_Item) then 2214 2215 -- Aspect case 2216 2217 if (Nkind (Prio_Item) = N_Aspect_Specification 2218 or else From_Aspect_Specification (Prio_Item)) 2219 and then Chars (Identifier (Prio_Item)) = Name_Priority 2220 then 2221 Error_Msg_N 2222 ("aspect Interrupt_Priority is preferred in presence of " 2223 & "handlers??", Prio_Item); 2224 2225 -- Pragma case 2226 2227 elsif Nkind (Prio_Item) = N_Pragma 2228 and then Pragma_Name (Prio_Item) = Name_Priority 2229 then 2230 Error_Msg_N 2231 ("pragma Interrupt_Priority is preferred in presence of " 2232 & "handlers??", Prio_Item); 2233 end if; 2234 end if; 2235 end; 2236 end if; 2237 2238 -- Case of a completion of a private declaration 2239 2240 if T /= Def_Id and then Is_Private_Type (Def_Id) then 2241 2242 -- Deal with preelaborable initialization. Note that this processing 2243 -- is done by Process_Full_View, but as can be seen below, in this 2244 -- case the call to Process_Full_View is skipped if any serious 2245 -- errors have occurred, and we don't want to lose this check. 2246 2247 if Known_To_Have_Preelab_Init (Def_Id) then 2248 Set_Must_Have_Preelab_Init (T); 2249 end if; 2250 2251 -- Propagate Default_Initial_Condition-related attributes from the 2252 -- private type to the protected type. 2253 2254 Propagate_DIC_Attributes (T, From_Typ => Def_Id); 2255 2256 -- Propagate invariant-related attributes from the private type to 2257 -- the protected type. 2258 2259 Propagate_Invariant_Attributes (T, From_Typ => Def_Id); 2260 2261 -- Create corresponding record now, because some private dependents 2262 -- may be subtypes of the partial view. 2263 2264 -- Skip if errors are present, to prevent cascaded messages 2265 2266 if Serious_Errors_Detected = 0 2267 2268 -- Also skip if expander is not active 2269 2270 and then Expander_Active 2271 then 2272 Expand_N_Protected_Type_Declaration (N); 2273 Process_Full_View (N, T, Def_Id); 2274 end if; 2275 end if; 2276 2277 -- In GNATprove mode, force the loading of a Interrupt_Priority, which 2278 -- is required for the ceiling priority protocol checks triggered by 2279 -- calls originating from protected subprograms and entries. 2280 2281 if GNATprove_Mode then 2282 SPARK_Implicit_Load (RE_Interrupt_Priority); 2283 end if; 2284 end Analyze_Protected_Type_Declaration; 2285 2286 --------------------- 2287 -- Analyze_Requeue -- 2288 --------------------- 2289 2290 procedure Analyze_Requeue (N : Node_Id) is 2291 Count : Natural := 0; 2292 Entry_Name : Node_Id := Name (N); 2293 Entry_Id : Entity_Id; 2294 I : Interp_Index; 2295 Is_Disp_Req : Boolean; 2296 It : Interp; 2297 Enclosing : Entity_Id; 2298 Target_Obj : Node_Id := Empty; 2299 Req_Scope : Entity_Id; 2300 Outer_Ent : Entity_Id; 2301 Synch_Type : Entity_Id := Empty; 2302 2303 begin 2304 -- Preserve relevant elaboration-related attributes of the context which 2305 -- are no longer available or very expensive to recompute once analysis, 2306 -- resolution, and expansion are over. 2307 2308 Mark_Elaboration_Attributes 2309 (N_Id => N, 2310 Checks => True, 2311 Modes => True, 2312 Warnings => True); 2313 2314 Tasking_Used := True; 2315 Check_SPARK_05_Restriction ("requeue statement is not allowed", N); 2316 Check_Restriction (No_Requeue_Statements, N); 2317 Check_Unreachable_Code (N); 2318 2319 Enclosing := Empty; 2320 for J in reverse 0 .. Scope_Stack.Last loop 2321 Enclosing := Scope_Stack.Table (J).Entity; 2322 exit when Is_Entry (Enclosing); 2323 2324 if not Ekind_In (Enclosing, E_Block, E_Loop) then 2325 Error_Msg_N ("requeue must appear within accept or entry body", N); 2326 return; 2327 end if; 2328 end loop; 2329 2330 Analyze (Entry_Name); 2331 2332 if Etype (Entry_Name) = Any_Type then 2333 return; 2334 end if; 2335 2336 if Nkind (Entry_Name) = N_Selected_Component then 2337 Target_Obj := Prefix (Entry_Name); 2338 Entry_Name := Selector_Name (Entry_Name); 2339 end if; 2340 2341 -- If an explicit target object is given then we have to check the 2342 -- restrictions of 9.5.4(6). 2343 2344 if Present (Target_Obj) then 2345 2346 -- Locate containing concurrent unit and determine enclosing entry 2347 -- body or outermost enclosing accept statement within the unit. 2348 2349 Outer_Ent := Empty; 2350 for S in reverse 0 .. Scope_Stack.Last loop 2351 Req_Scope := Scope_Stack.Table (S).Entity; 2352 2353 exit when Is_Concurrent_Type (Req_Scope); 2354 2355 if Is_Entry (Req_Scope) then 2356 Outer_Ent := Req_Scope; 2357 end if; 2358 end loop; 2359 2360 pragma Assert (Present (Outer_Ent)); 2361 2362 -- Check that the accessibility level of the target object is not 2363 -- greater or equal to the outermost enclosing accept statement (or 2364 -- entry body) unless it is a parameter of the innermost enclosing 2365 -- accept statement (or entry body). 2366 2367 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) 2368 and then 2369 (not Is_Entity_Name (Target_Obj) 2370 or else not Is_Formal (Entity (Target_Obj)) 2371 or else Enclosing /= Scope (Entity (Target_Obj))) 2372 then 2373 Error_Msg_N 2374 ("target object has invalid level for requeue", Target_Obj); 2375 end if; 2376 end if; 2377 2378 -- Overloaded case, find right interpretation 2379 2380 if Is_Overloaded (Entry_Name) then 2381 Entry_Id := Empty; 2382 2383 -- Loop over candidate interpretations and filter out any that are 2384 -- not parameterless, are not type conformant, are not entries, or 2385 -- do not come from source. 2386 2387 Get_First_Interp (Entry_Name, I, It); 2388 while Present (It.Nam) loop 2389 2390 -- Note: we test type conformance here, not subtype conformance. 2391 -- Subtype conformance will be tested later on, but it is better 2392 -- for error output in some cases not to do that here. 2393 2394 if (No (First_Formal (It.Nam)) 2395 or else (Type_Conformant (Enclosing, It.Nam))) 2396 and then Ekind (It.Nam) = E_Entry 2397 then 2398 -- Ada 2005 (AI-345): Since protected and task types have 2399 -- primitive entry wrappers, we only consider source entries. 2400 2401 if Comes_From_Source (It.Nam) then 2402 Count := Count + 1; 2403 Entry_Id := It.Nam; 2404 else 2405 Remove_Interp (I); 2406 end if; 2407 end if; 2408 2409 Get_Next_Interp (I, It); 2410 end loop; 2411 2412 if Count = 0 then 2413 Error_Msg_N ("no entry matches context", N); 2414 return; 2415 2416 elsif Count > 1 then 2417 Error_Msg_N ("ambiguous entry name in requeue", N); 2418 return; 2419 2420 else 2421 Set_Is_Overloaded (Entry_Name, False); 2422 Set_Entity (Entry_Name, Entry_Id); 2423 end if; 2424 2425 -- Non-overloaded cases 2426 2427 -- For the case of a reference to an element of an entry family, the 2428 -- Entry_Name is an indexed component. 2429 2430 elsif Nkind (Entry_Name) = N_Indexed_Component then 2431 2432 -- Requeue to an entry out of the body 2433 2434 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then 2435 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name))); 2436 2437 -- Requeue from within the body itself 2438 2439 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then 2440 Entry_Id := Entity (Prefix (Entry_Name)); 2441 2442 else 2443 Error_Msg_N ("invalid entry_name specified", N); 2444 return; 2445 end if; 2446 2447 -- If we had a requeue of the form REQUEUE A (B), then the parser 2448 -- accepted it (because it could have been a requeue on an entry index. 2449 -- If A turns out not to be an entry family, then the analysis of A (B) 2450 -- turned it into a function call. 2451 2452 elsif Nkind (Entry_Name) = N_Function_Call then 2453 Error_Msg_N 2454 ("arguments not allowed in requeue statement", 2455 First (Parameter_Associations (Entry_Name))); 2456 return; 2457 2458 -- Normal case of no entry family, no argument 2459 2460 else 2461 Entry_Id := Entity (Entry_Name); 2462 end if; 2463 2464 -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The 2465 -- target type must be a concurrent interface class-wide type and the 2466 -- target must be a procedure, flagged by pragma Implemented. The 2467 -- target may be an access to class-wide type, in which case it must 2468 -- be dereferenced. 2469 2470 if Present (Target_Obj) then 2471 Synch_Type := Etype (Target_Obj); 2472 2473 if Is_Access_Type (Synch_Type) then 2474 Synch_Type := Designated_Type (Synch_Type); 2475 end if; 2476 end if; 2477 2478 Is_Disp_Req := 2479 Ada_Version >= Ada_2012 2480 and then Present (Target_Obj) 2481 and then Is_Class_Wide_Type (Synch_Type) 2482 and then Is_Concurrent_Interface (Synch_Type) 2483 and then Ekind (Entry_Id) = E_Procedure 2484 and then Has_Rep_Pragma (Entry_Id, Name_Implemented); 2485 2486 -- Resolve entry, and check that it is subtype conformant with the 2487 -- enclosing construct if this construct has formals (RM 9.5.4(5)). 2488 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case. 2489 2490 if not Is_Entry (Entry_Id) 2491 and then not Is_Disp_Req 2492 then 2493 Error_Msg_N ("expect entry name in requeue statement", Name (N)); 2494 2495 elsif Ekind (Entry_Id) = E_Entry_Family 2496 and then Nkind (Entry_Name) /= N_Indexed_Component 2497 then 2498 Error_Msg_N ("missing index for entry family component", Name (N)); 2499 2500 else 2501 Resolve_Entry (Name (N)); 2502 Generate_Reference (Entry_Id, Entry_Name); 2503 2504 if Present (First_Formal (Entry_Id)) then 2505 2506 -- Ada 2012 (AI05-0030): Perform type conformance after skipping 2507 -- the first parameter of Entry_Id since it is the interface 2508 -- controlling formal. 2509 2510 if Ada_Version >= Ada_2012 and then Is_Disp_Req then 2511 declare 2512 Enclosing_Formal : Entity_Id; 2513 Target_Formal : Entity_Id; 2514 2515 begin 2516 Enclosing_Formal := First_Formal (Enclosing); 2517 Target_Formal := Next_Formal (First_Formal (Entry_Id)); 2518 while Present (Enclosing_Formal) 2519 and then Present (Target_Formal) 2520 loop 2521 if not Conforming_Types 2522 (T1 => Etype (Enclosing_Formal), 2523 T2 => Etype (Target_Formal), 2524 Ctype => Subtype_Conformant) 2525 then 2526 Error_Msg_Node_2 := Target_Formal; 2527 Error_Msg_NE 2528 ("formal & is not subtype conformant with &" & 2529 "in dispatching requeue", N, Enclosing_Formal); 2530 end if; 2531 2532 Next_Formal (Enclosing_Formal); 2533 Next_Formal (Target_Formal); 2534 end loop; 2535 end; 2536 else 2537 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); 2538 end if; 2539 2540 -- Processing for parameters accessed by the requeue 2541 2542 declare 2543 Ent : Entity_Id; 2544 2545 begin 2546 Ent := First_Formal (Enclosing); 2547 while Present (Ent) loop 2548 2549 -- For OUT or IN OUT parameter, the effect of the requeue is 2550 -- to assign the parameter a value on exit from the requeued 2551 -- body, so we can set it as source assigned. We also clear 2552 -- the Is_True_Constant indication. We do not need to clear 2553 -- Current_Value, since the effect of the requeue is to 2554 -- perform an unconditional goto so that any further 2555 -- references will not occur anyway. 2556 2557 if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then 2558 Set_Never_Set_In_Source (Ent, False); 2559 Set_Is_True_Constant (Ent, False); 2560 end if; 2561 2562 -- For all parameters, the requeue acts as a reference, 2563 -- since the value of the parameter is passed to the new 2564 -- entry, so we want to suppress unreferenced warnings. 2565 2566 Set_Referenced (Ent); 2567 Next_Formal (Ent); 2568 end loop; 2569 end; 2570 end if; 2571 end if; 2572 2573 -- AI05-0225: the target protected object of a requeue must be a 2574 -- variable. This is a binding interpretation that applies to all 2575 -- versions of the language. Note that the subprogram does not have 2576 -- to be a protected operation: it can be an primitive implemented 2577 -- by entry with a formal that is a protected interface. 2578 2579 if Present (Target_Obj) 2580 and then not Is_Variable (Target_Obj) 2581 then 2582 Error_Msg_N 2583 ("target protected object of requeue must be a variable", N); 2584 end if; 2585 2586 -- A requeue statement is treated as a call for purposes of ABE checks 2587 -- and diagnostics. Annotate the tree by creating a call marker in case 2588 -- the requeue statement is transformed by expansion. 2589 2590 Build_Call_Marker (N); 2591 end Analyze_Requeue; 2592 2593 ------------------------------ 2594 -- Analyze_Selective_Accept -- 2595 ------------------------------ 2596 2597 procedure Analyze_Selective_Accept (N : Node_Id) is 2598 Alts : constant List_Id := Select_Alternatives (N); 2599 Alt : Node_Id; 2600 2601 Accept_Present : Boolean := False; 2602 Terminate_Present : Boolean := False; 2603 Delay_Present : Boolean := False; 2604 Relative_Present : Boolean := False; 2605 Alt_Count : Uint := Uint_0; 2606 2607 begin 2608 Tasking_Used := True; 2609 Check_SPARK_05_Restriction ("select statement is not allowed", N); 2610 Check_Restriction (No_Select_Statements, N); 2611 2612 -- Loop to analyze alternatives 2613 2614 Alt := First (Alts); 2615 while Present (Alt) loop 2616 Alt_Count := Alt_Count + 1; 2617 Analyze (Alt); 2618 2619 if Nkind (Alt) = N_Delay_Alternative then 2620 if Delay_Present then 2621 2622 if Relative_Present /= 2623 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement) 2624 then 2625 Error_Msg_N 2626 ("delay_until and delay_relative alternatives ", Alt); 2627 Error_Msg_N 2628 ("\cannot appear in the same selective_wait", Alt); 2629 end if; 2630 2631 else 2632 Delay_Present := True; 2633 Relative_Present := 2634 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement; 2635 end if; 2636 2637 elsif Nkind (Alt) = N_Terminate_Alternative then 2638 if Terminate_Present then 2639 Error_Msg_N ("only one terminate alternative allowed", N); 2640 else 2641 Terminate_Present := True; 2642 Check_Restriction (No_Terminate_Alternatives, N); 2643 end if; 2644 2645 elsif Nkind (Alt) = N_Accept_Alternative then 2646 Accept_Present := True; 2647 2648 -- Check for duplicate accept 2649 2650 declare 2651 Alt1 : Node_Id; 2652 Stm : constant Node_Id := Accept_Statement (Alt); 2653 EDN : constant Node_Id := Entry_Direct_Name (Stm); 2654 Ent : Entity_Id; 2655 2656 begin 2657 if Nkind (EDN) = N_Identifier 2658 and then No (Condition (Alt)) 2659 and then Present (Entity (EDN)) -- defend against junk 2660 and then Ekind (Entity (EDN)) = E_Entry 2661 then 2662 Ent := Entity (EDN); 2663 2664 Alt1 := First (Alts); 2665 while Alt1 /= Alt loop 2666 if Nkind (Alt1) = N_Accept_Alternative 2667 and then No (Condition (Alt1)) 2668 then 2669 declare 2670 Stm1 : constant Node_Id := Accept_Statement (Alt1); 2671 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1); 2672 2673 begin 2674 if Nkind (EDN1) = N_Identifier then 2675 if Entity (EDN1) = Ent then 2676 Error_Msg_Sloc := Sloc (Stm1); 2677 Error_Msg_N 2678 ("accept duplicates one on line#??", Stm); 2679 exit; 2680 end if; 2681 end if; 2682 end; 2683 end if; 2684 2685 Next (Alt1); 2686 end loop; 2687 end if; 2688 end; 2689 end if; 2690 2691 Next (Alt); 2692 end loop; 2693 2694 Check_Restriction (Max_Select_Alternatives, N, Alt_Count); 2695 Check_Potentially_Blocking_Operation (N); 2696 2697 if Terminate_Present and Delay_Present then 2698 Error_Msg_N ("at most one of terminate or delay alternative", N); 2699 2700 elsif not Accept_Present then 2701 Error_Msg_N 2702 ("select must contain at least one accept alternative", N); 2703 end if; 2704 2705 if Present (Else_Statements (N)) then 2706 if Terminate_Present or Delay_Present then 2707 Error_Msg_N ("else part not allowed with other alternatives", N); 2708 end if; 2709 2710 Analyze_Statements (Else_Statements (N)); 2711 end if; 2712 end Analyze_Selective_Accept; 2713 2714 ------------------------------------------ 2715 -- Analyze_Single_Protected_Declaration -- 2716 ------------------------------------------ 2717 2718 procedure Analyze_Single_Protected_Declaration (N : Node_Id) is 2719 Loc : constant Source_Ptr := Sloc (N); 2720 Obj_Id : constant Node_Id := Defining_Identifier (N); 2721 Obj_Decl : Node_Id; 2722 Typ : Entity_Id; 2723 2724 begin 2725 Generate_Definition (Obj_Id); 2726 Tasking_Used := True; 2727 2728 -- A single protected declaration is transformed into a pair of an 2729 -- anonymous protected type and an object of that type. Generate: 2730 2731 -- protected type Typ is ...; 2732 2733 Typ := 2734 Make_Defining_Identifier (Sloc (Obj_Id), 2735 Chars => New_External_Name (Chars (Obj_Id), 'T')); 2736 2737 Rewrite (N, 2738 Make_Protected_Type_Declaration (Loc, 2739 Defining_Identifier => Typ, 2740 Protected_Definition => Relocate_Node (Protected_Definition (N)), 2741 Interface_List => Interface_List (N))); 2742 2743 -- Use the original defining identifier of the single protected 2744 -- declaration in the generated object declaration to allow for debug 2745 -- information to be attached to it when compiling with -gnatD. The 2746 -- parent of the entity is the new object declaration. The single 2747 -- protected declaration is not used in semantics or code generation, 2748 -- but is scanned when generating debug information, and therefore needs 2749 -- the updated Sloc information from the entity (see Sprint). Generate: 2750 2751 -- Obj : Typ; 2752 2753 Obj_Decl := 2754 Make_Object_Declaration (Loc, 2755 Defining_Identifier => Obj_Id, 2756 Object_Definition => New_Occurrence_Of (Typ, Loc)); 2757 2758 Insert_After (N, Obj_Decl); 2759 Mark_Rewrite_Insertion (Obj_Decl); 2760 2761 -- Relocate aspect Part_Of from the original single protected 2762 -- declaration to the anonymous object declaration. This emulates the 2763 -- placement of an equivalent source pragma. 2764 2765 Move_Or_Merge_Aspects (N, To => Obj_Decl); 2766 2767 -- Relocate pragma Part_Of from the visible declarations of the original 2768 -- single protected declaration to the anonymous object declaration. The 2769 -- new placement better reflects the role of the pragma. 2770 2771 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); 2772 2773 -- Enter the names of the anonymous protected type and the object before 2774 -- analysis takes places, because the name of the object may be used in 2775 -- its own body. 2776 2777 Enter_Name (Typ); 2778 Set_Ekind (Typ, E_Protected_Type); 2779 Set_Etype (Typ, Typ); 2780 Set_Anonymous_Object (Typ, Obj_Id); 2781 2782 Enter_Name (Obj_Id); 2783 Set_Ekind (Obj_Id, E_Variable); 2784 Set_Etype (Obj_Id, Typ); 2785 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); 2786 Set_SPARK_Pragma_Inherited (Obj_Id); 2787 2788 -- Instead of calling Analyze on the new node, call the proper analysis 2789 -- procedure directly. Otherwise the node would be expanded twice, with 2790 -- disastrous result. 2791 2792 Analyze_Protected_Type_Declaration (N); 2793 2794 if Has_Aspects (N) then 2795 Analyze_Aspect_Specifications (N, Obj_Id); 2796 end if; 2797 end Analyze_Single_Protected_Declaration; 2798 2799 ------------------------------------- 2800 -- Analyze_Single_Task_Declaration -- 2801 ------------------------------------- 2802 2803 procedure Analyze_Single_Task_Declaration (N : Node_Id) is 2804 Loc : constant Source_Ptr := Sloc (N); 2805 Obj_Id : constant Node_Id := Defining_Identifier (N); 2806 Obj_Decl : Node_Id; 2807 Typ : Entity_Id; 2808 2809 begin 2810 Generate_Definition (Obj_Id); 2811 Tasking_Used := True; 2812 2813 -- A single task declaration is transformed into a pair of an anonymous 2814 -- task type and an object of that type. Generate: 2815 2816 -- task type Typ is ...; 2817 2818 Typ := 2819 Make_Defining_Identifier (Sloc (Obj_Id), 2820 Chars => New_External_Name (Chars (Obj_Id), Suffix => "TK")); 2821 2822 Rewrite (N, 2823 Make_Task_Type_Declaration (Loc, 2824 Defining_Identifier => Typ, 2825 Task_Definition => Relocate_Node (Task_Definition (N)), 2826 Interface_List => Interface_List (N))); 2827 2828 -- Use the original defining identifier of the single task declaration 2829 -- in the generated object declaration to allow for debug information 2830 -- to be attached to it when compiling with -gnatD. The parent of the 2831 -- entity is the new object declaration. The single task declaration 2832 -- is not used in semantics or code generation, but is scanned when 2833 -- generating debug information, and therefore needs the updated Sloc 2834 -- information from the entity (see Sprint). Generate: 2835 2836 -- Obj : Typ; 2837 2838 Obj_Decl := 2839 Make_Object_Declaration (Loc, 2840 Defining_Identifier => Obj_Id, 2841 Object_Definition => New_Occurrence_Of (Typ, Loc)); 2842 2843 Insert_After (N, Obj_Decl); 2844 Mark_Rewrite_Insertion (Obj_Decl); 2845 2846 -- Relocate aspects Depends, Global and Part_Of from the original single 2847 -- task declaration to the anonymous object declaration. This emulates 2848 -- the placement of an equivalent source pragma. 2849 2850 Move_Or_Merge_Aspects (N, To => Obj_Decl); 2851 2852 -- Relocate pragmas Depends, Global and Part_Of from the visible 2853 -- declarations of the original single protected declaration to the 2854 -- anonymous object declaration. The new placement better reflects the 2855 -- role of the pragmas. 2856 2857 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); 2858 2859 -- Enter the names of the anonymous task type and the object before 2860 -- analysis takes places, because the name of the object may be used 2861 -- in its own body. 2862 2863 Enter_Name (Typ); 2864 Set_Ekind (Typ, E_Task_Type); 2865 Set_Etype (Typ, Typ); 2866 Set_Anonymous_Object (Typ, Obj_Id); 2867 2868 Enter_Name (Obj_Id); 2869 Set_Ekind (Obj_Id, E_Variable); 2870 Set_Etype (Obj_Id, Typ); 2871 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); 2872 Set_SPARK_Pragma_Inherited (Obj_Id); 2873 2874 -- Preserve relevant elaboration-related attributes of the context which 2875 -- are no longer available or very expensive to recompute once analysis, 2876 -- resolution, and expansion are over. 2877 2878 Mark_Elaboration_Attributes 2879 (N_Id => Obj_Id, 2880 Checks => True, 2881 Warnings => True); 2882 2883 -- Instead of calling Analyze on the new node, call the proper analysis 2884 -- procedure directly. Otherwise the node would be expanded twice, with 2885 -- disastrous result. 2886 2887 Analyze_Task_Type_Declaration (N); 2888 2889 if Has_Aspects (N) then 2890 Analyze_Aspect_Specifications (N, Obj_Id); 2891 end if; 2892 end Analyze_Single_Task_Declaration; 2893 2894 ----------------------- 2895 -- Analyze_Task_Body -- 2896 ----------------------- 2897 2898 procedure Analyze_Task_Body (N : Node_Id) is 2899 Body_Id : constant Entity_Id := Defining_Identifier (N); 2900 Decls : constant List_Id := Declarations (N); 2901 HSS : constant Node_Id := Handled_Statement_Sequence (N); 2902 Last_E : Entity_Id; 2903 2904 Spec_Id : Entity_Id; 2905 -- This is initially the entity of the task or task type involved, but 2906 -- is replaced by the task type always in the case of a single task 2907 -- declaration, since this is the proper scope to be used. 2908 2909 Ref_Id : Entity_Id; 2910 -- This is the entity of the task or task type, and is the entity used 2911 -- for cross-reference purposes (it differs from Spec_Id in the case of 2912 -- a single task, since Spec_Id is set to the task type). 2913 2914 begin 2915 -- A task body freezes the contract of the nearest enclosing package 2916 -- body and all other contracts encountered in the same declarative part 2917 -- up to and excluding the task body. This ensures that annotations 2918 -- referenced by the contract of an entry or subprogram body declared 2919 -- within the current protected body are available. 2920 2921 Freeze_Previous_Contracts (N); 2922 2923 Tasking_Used := True; 2924 Set_Scope (Body_Id, Current_Scope); 2925 Set_Ekind (Body_Id, E_Task_Body); 2926 Set_Etype (Body_Id, Standard_Void_Type); 2927 Spec_Id := Find_Concurrent_Spec (Body_Id); 2928 2929 -- The spec is either a task type declaration, or a single task 2930 -- declaration for which we have created an anonymous type. 2931 2932 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Task_Type then 2933 null; 2934 2935 elsif Present (Spec_Id) 2936 and then Ekind (Etype (Spec_Id)) = E_Task_Type 2937 and then not Comes_From_Source (Etype (Spec_Id)) 2938 then 2939 null; 2940 2941 else 2942 Error_Msg_N ("missing specification for task body", Body_Id); 2943 return; 2944 end if; 2945 2946 if Has_Completion (Spec_Id) 2947 and then Present (Corresponding_Body (Parent (Spec_Id))) 2948 then 2949 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then 2950 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id); 2951 else 2952 Error_Msg_NE ("duplicate body for task&", N, Spec_Id); 2953 end if; 2954 end if; 2955 2956 Ref_Id := Spec_Id; 2957 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); 2958 Style.Check_Identifier (Body_Id, Spec_Id); 2959 2960 -- Deal with case of body of single task (anonymous type was created) 2961 2962 if Ekind (Spec_Id) = E_Variable then 2963 Spec_Id := Etype (Spec_Id); 2964 end if; 2965 2966 -- Set the SPARK_Mode from the current context (may be overwritten later 2967 -- with an explicit pragma). 2968 2969 Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); 2970 Set_SPARK_Pragma_Inherited (Body_Id); 2971 2972 if Has_Aspects (N) then 2973 Analyze_Aspect_Specifications (N, Body_Id); 2974 end if; 2975 2976 Push_Scope (Spec_Id); 2977 Set_Corresponding_Spec (N, Spec_Id); 2978 Set_Corresponding_Body (Parent (Spec_Id), Body_Id); 2979 Set_Has_Completion (Spec_Id); 2980 Install_Declarations (Spec_Id); 2981 Last_E := Last_Entity (Spec_Id); 2982 2983 Analyze_Declarations (Decls); 2984 Inspect_Deferred_Constant_Completion (Decls); 2985 2986 -- For visibility purposes, all entities in the body are private. Set 2987 -- First_Private_Entity accordingly, if there was no private part in the 2988 -- protected declaration. 2989 2990 if No (First_Private_Entity (Spec_Id)) then 2991 if Present (Last_E) then 2992 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); 2993 else 2994 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); 2995 end if; 2996 end if; 2997 2998 -- Mark all handlers as not suitable for local raise optimization, 2999 -- since this optimization causes difficulties in a task context. 3000 3001 if Present (Exception_Handlers (HSS)) then 3002 declare 3003 Handlr : Node_Id; 3004 begin 3005 Handlr := First (Exception_Handlers (HSS)); 3006 while Present (Handlr) loop 3007 Set_Local_Raise_Not_OK (Handlr); 3008 Next (Handlr); 3009 end loop; 3010 end; 3011 end if; 3012 3013 -- Now go ahead and complete analysis of the task body 3014 3015 Analyze (HSS); 3016 Check_Completion (Body_Id); 3017 Check_References (Body_Id); 3018 Check_References (Spec_Id); 3019 3020 -- Check for entries with no corresponding accept 3021 3022 declare 3023 Ent : Entity_Id; 3024 3025 begin 3026 Ent := First_Entity (Spec_Id); 3027 while Present (Ent) loop 3028 if Is_Entry (Ent) 3029 and then not Entry_Accepted (Ent) 3030 and then Comes_From_Source (Ent) 3031 then 3032 Error_Msg_NE ("no accept for entry &??", N, Ent); 3033 end if; 3034 3035 Next_Entity (Ent); 3036 end loop; 3037 end; 3038 3039 Process_End_Label (HSS, 't', Ref_Id); 3040 Update_Use_Clause_Chain; 3041 End_Scope; 3042 end Analyze_Task_Body; 3043 3044 ----------------------------- 3045 -- Analyze_Task_Definition -- 3046 ----------------------------- 3047 3048 procedure Analyze_Task_Definition (N : Node_Id) is 3049 L : Entity_Id; 3050 3051 begin 3052 Tasking_Used := True; 3053 Check_SPARK_05_Restriction ("task definition is not allowed", N); 3054 3055 if Present (Visible_Declarations (N)) then 3056 Analyze_Declarations (Visible_Declarations (N)); 3057 end if; 3058 3059 if Present (Private_Declarations (N)) then 3060 L := Last_Entity (Current_Scope); 3061 Analyze_Declarations (Private_Declarations (N)); 3062 3063 if Present (L) then 3064 Set_First_Private_Entity 3065 (Current_Scope, Next_Entity (L)); 3066 else 3067 Set_First_Private_Entity 3068 (Current_Scope, First_Entity (Current_Scope)); 3069 end if; 3070 end if; 3071 3072 Check_Max_Entries (N, Max_Task_Entries); 3073 Process_End_Label (N, 'e', Current_Scope); 3074 end Analyze_Task_Definition; 3075 3076 ----------------------------------- 3077 -- Analyze_Task_Type_Declaration -- 3078 ----------------------------------- 3079 3080 procedure Analyze_Task_Type_Declaration (N : Node_Id) is 3081 Def_Id : constant Entity_Id := Defining_Identifier (N); 3082 T : Entity_Id; 3083 3084 begin 3085 -- Attempt to use tasking in no run time mode is not allowe. Issue hard 3086 -- error message to disable expansion which leads to crashes. 3087 3088 if Opt.No_Run_Time_Mode then 3089 Error_Msg_N ("tasking not allowed in No_Run_Time mode", N); 3090 3091 -- Otherwise soft check for no tasking restriction 3092 3093 else 3094 Check_Restriction (No_Tasking, N); 3095 end if; 3096 3097 -- Proceed ahead with analysis of task type declaration 3098 3099 Tasking_Used := True; 3100 3101 -- The sequential partition elaboration policy is supported only in the 3102 -- restricted profile. 3103 3104 if Partition_Elaboration_Policy = 'S' 3105 and then not Restricted_Profile 3106 then 3107 Error_Msg_N 3108 ("sequential elaboration supported only in restricted profile", N); 3109 end if; 3110 3111 T := Find_Type_Name (N); 3112 Generate_Definition (T); 3113 3114 -- In the case of an incomplete type, use the full view, unless it's not 3115 -- present (as can occur for an incomplete view from a limited with). 3116 -- Initialize the Corresponding_Record_Type (which overlays the Private 3117 -- Dependents field of the incomplete view). 3118 3119 if Ekind (T) = E_Incomplete_Type then 3120 if Present (Full_View (T)) then 3121 T := Full_View (T); 3122 Set_Completion_Referenced (T); 3123 3124 else 3125 Set_Ekind (T, E_Task_Type); 3126 Set_Corresponding_Record_Type (T, Empty); 3127 end if; 3128 end if; 3129 3130 Set_Ekind (T, E_Task_Type); 3131 Set_Is_First_Subtype (T, True); 3132 Set_Has_Task (T, True); 3133 Init_Size_Align (T); 3134 Set_Etype (T, T); 3135 Set_Has_Delayed_Freeze (T, True); 3136 Set_Stored_Constraint (T, No_Elist); 3137 3138 -- Set the SPARK_Mode from the current context (may be overwritten later 3139 -- with an explicit pragma). 3140 3141 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 3142 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); 3143 Set_SPARK_Pragma_Inherited (T); 3144 Set_SPARK_Aux_Pragma_Inherited (T); 3145 3146 -- Preserve relevant elaboration-related attributes of the context which 3147 -- are no longer available or very expensive to recompute once analysis, 3148 -- resolution, and expansion are over. 3149 3150 Mark_Elaboration_Attributes 3151 (N_Id => T, 3152 Checks => True, 3153 Warnings => True); 3154 3155 Push_Scope (T); 3156 3157 if Ada_Version >= Ada_2005 then 3158 Check_Interfaces (N, T); 3159 end if; 3160 3161 if Present (Discriminant_Specifications (N)) then 3162 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 3163 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); 3164 end if; 3165 3166 if Has_Discriminants (T) then 3167 3168 -- Install discriminants. Also, verify conformance of 3169 -- discriminants of previous and current view. ??? 3170 3171 Install_Declarations (T); 3172 else 3173 Process_Discriminants (N); 3174 end if; 3175 end if; 3176 3177 Set_Is_Constrained (T, not Has_Discriminants (T)); 3178 3179 if Has_Aspects (N) then 3180 3181 -- The task type is the full view of a private type. Analyze the 3182 -- aspects with the entity of the private type to ensure that after 3183 -- both views are exchanged, the aspect are actually associated with 3184 -- the full view. 3185 3186 if T /= Def_Id and then Is_Private_Type (Def_Id) then 3187 Analyze_Aspect_Specifications (N, T); 3188 else 3189 Analyze_Aspect_Specifications (N, Def_Id); 3190 end if; 3191 end if; 3192 3193 if Present (Task_Definition (N)) then 3194 Analyze_Task_Definition (Task_Definition (N)); 3195 end if; 3196 3197 -- In the case where the task type is declared at a nested level and the 3198 -- No_Task_Hierarchy restriction applies, issue a warning that objects 3199 -- of the type will violate the restriction. 3200 3201 if Restriction_Check_Required (No_Task_Hierarchy) 3202 and then not Is_Library_Level_Entity (T) 3203 and then Comes_From_Source (T) 3204 and then not CodePeer_Mode 3205 then 3206 Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); 3207 3208 if Error_Msg_Sloc = No_Location then 3209 Error_Msg_N 3210 ("objects of this type will violate `No_Task_Hierarchy`??", N); 3211 else 3212 Error_Msg_N 3213 ("objects of this type will violate `No_Task_Hierarchy`#??", N); 3214 end if; 3215 end if; 3216 3217 End_Scope; 3218 3219 -- Case of a completion of a private declaration 3220 3221 if T /= Def_Id and then Is_Private_Type (Def_Id) then 3222 3223 -- Deal with preelaborable initialization. Note that this processing 3224 -- is done by Process_Full_View, but as can be seen below, in this 3225 -- case the call to Process_Full_View is skipped if any serious 3226 -- errors have occurred, and we don't want to lose this check. 3227 3228 if Known_To_Have_Preelab_Init (Def_Id) then 3229 Set_Must_Have_Preelab_Init (T); 3230 end if; 3231 3232 -- Propagate Default_Initial_Condition-related attributes from the 3233 -- private type to the task type. 3234 3235 Propagate_DIC_Attributes (T, From_Typ => Def_Id); 3236 3237 -- Propagate invariant-related attributes from the private type to 3238 -- task type. 3239 3240 Propagate_Invariant_Attributes (T, From_Typ => Def_Id); 3241 3242 -- Create corresponding record now, because some private dependents 3243 -- may be subtypes of the partial view. 3244 3245 -- Skip if errors are present, to prevent cascaded messages 3246 3247 if Serious_Errors_Detected = 0 3248 3249 -- Also skip if expander is not active 3250 3251 and then Expander_Active 3252 then 3253 Expand_N_Task_Type_Declaration (N); 3254 Process_Full_View (N, T, Def_Id); 3255 end if; 3256 end if; 3257 3258 -- In GNATprove mode, force the loading of a Interrupt_Priority, which 3259 -- is required for the ceiling priority protocol checks triggered by 3260 -- calls originating from tasks. 3261 3262 if GNATprove_Mode then 3263 SPARK_Implicit_Load (RE_Interrupt_Priority); 3264 end if; 3265 end Analyze_Task_Type_Declaration; 3266 3267 ----------------------------------- 3268 -- Analyze_Terminate_Alternative -- 3269 ----------------------------------- 3270 3271 procedure Analyze_Terminate_Alternative (N : Node_Id) is 3272 begin 3273 Tasking_Used := True; 3274 3275 if Present (Pragmas_Before (N)) then 3276 Analyze_List (Pragmas_Before (N)); 3277 end if; 3278 3279 if Present (Condition (N)) then 3280 Analyze_And_Resolve (Condition (N), Any_Boolean); 3281 end if; 3282 end Analyze_Terminate_Alternative; 3283 3284 ------------------------------ 3285 -- Analyze_Timed_Entry_Call -- 3286 ------------------------------ 3287 3288 procedure Analyze_Timed_Entry_Call (N : Node_Id) is 3289 Trigger : constant Node_Id := 3290 Entry_Call_Statement (Entry_Call_Alternative (N)); 3291 Is_Disp_Select : Boolean := False; 3292 3293 begin 3294 Tasking_Used := True; 3295 Check_SPARK_05_Restriction ("select statement is not allowed", N); 3296 Check_Restriction (No_Select_Statements, N); 3297 3298 -- Ada 2005 (AI-345): The trigger may be a dispatching call 3299 3300 if Ada_Version >= Ada_2005 then 3301 Analyze (Trigger); 3302 Check_Triggering_Statement (Trigger, N, Is_Disp_Select); 3303 end if; 3304 3305 -- Postpone the analysis of the statements till expansion. Analyze only 3306 -- if the expander is disabled in order to catch any semantic errors. 3307 3308 if Is_Disp_Select then 3309 if not Expander_Active then 3310 Analyze (Entry_Call_Alternative (N)); 3311 Analyze (Delay_Alternative (N)); 3312 end if; 3313 3314 -- Regular select analysis 3315 3316 else 3317 Analyze (Entry_Call_Alternative (N)); 3318 Analyze (Delay_Alternative (N)); 3319 end if; 3320 end Analyze_Timed_Entry_Call; 3321 3322 ------------------------------------ 3323 -- Analyze_Triggering_Alternative -- 3324 ------------------------------------ 3325 3326 procedure Analyze_Triggering_Alternative (N : Node_Id) is 3327 Trigger : constant Node_Id := Triggering_Statement (N); 3328 3329 begin 3330 Tasking_Used := True; 3331 3332 if Present (Pragmas_Before (N)) then 3333 Analyze_List (Pragmas_Before (N)); 3334 end if; 3335 3336 Analyze (Trigger); 3337 3338 if Comes_From_Source (Trigger) 3339 and then Nkind (Trigger) not in N_Delay_Statement 3340 and then Nkind (Trigger) /= N_Entry_Call_Statement 3341 then 3342 if Ada_Version < Ada_2005 then 3343 Error_Msg_N 3344 ("triggering statement must be delay or entry call", Trigger); 3345 3346 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a 3347 -- procedure_or_entry_call, the procedure_name or procedure_prefix 3348 -- of the procedure_call_statement shall denote an entry renamed by a 3349 -- procedure, or (a view of) a primitive subprogram of a limited 3350 -- interface whose first parameter is a controlling parameter. 3351 3352 elsif Nkind (Trigger) = N_Procedure_Call_Statement 3353 and then not Is_Renamed_Entry (Entity (Name (Trigger))) 3354 and then not Is_Controlling_Limited_Procedure 3355 (Entity (Name (Trigger))) 3356 then 3357 Error_Msg_N 3358 ("triggering statement must be procedure or entry call " & 3359 "or delay statement", Trigger); 3360 end if; 3361 end if; 3362 3363 if Is_Non_Empty_List (Statements (N)) then 3364 Analyze_Statements (Statements (N)); 3365 end if; 3366 end Analyze_Triggering_Alternative; 3367 3368 ----------------------- 3369 -- Check_Max_Entries -- 3370 ----------------------- 3371 3372 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is 3373 Ecount : Uint; 3374 3375 procedure Count (L : List_Id); 3376 -- Count entries in given declaration list 3377 3378 ----------- 3379 -- Count -- 3380 ----------- 3381 3382 procedure Count (L : List_Id) is 3383 D : Node_Id; 3384 3385 begin 3386 if No (L) then 3387 return; 3388 end if; 3389 3390 D := First (L); 3391 while Present (D) loop 3392 if Nkind (D) = N_Entry_Declaration then 3393 declare 3394 DSD : constant Node_Id := 3395 Discrete_Subtype_Definition (D); 3396 3397 begin 3398 -- If not an entry family, then just one entry 3399 3400 if No (DSD) then 3401 Ecount := Ecount + 1; 3402 3403 -- If entry family with static bounds, count entries 3404 3405 elsif Is_OK_Static_Subtype (Etype (DSD)) then 3406 declare 3407 Lo : constant Uint := 3408 Expr_Value 3409 (Type_Low_Bound (Etype (DSD))); 3410 Hi : constant Uint := 3411 Expr_Value 3412 (Type_High_Bound (Etype (DSD))); 3413 3414 begin 3415 if Hi >= Lo then 3416 Ecount := Ecount + Hi - Lo + 1; 3417 end if; 3418 end; 3419 3420 -- Entry family with non-static bounds 3421 3422 else 3423 -- Record an unknown count restriction, and if the 3424 -- restriction is active, post a message or warning. 3425 3426 Check_Restriction (R, D); 3427 end if; 3428 end; 3429 end if; 3430 3431 Next (D); 3432 end loop; 3433 end Count; 3434 3435 -- Start of processing for Check_Max_Entries 3436 3437 begin 3438 Ecount := Uint_0; 3439 Count (Visible_Declarations (D)); 3440 Count (Private_Declarations (D)); 3441 3442 if Ecount > 0 then 3443 Check_Restriction (R, D, Ecount); 3444 end if; 3445 end Check_Max_Entries; 3446 3447 ---------------------- 3448 -- Check_Interfaces -- 3449 ---------------------- 3450 3451 procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is 3452 Iface : Node_Id; 3453 Iface_Typ : Entity_Id; 3454 3455 begin 3456 pragma Assert 3457 (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration)); 3458 3459 if Present (Interface_List (N)) then 3460 Set_Is_Tagged_Type (T); 3461 3462 -- The primitive operations of a tagged synchronized type are placed 3463 -- on the Corresponding_Record for proper dispatching, but are 3464 -- attached to the synchronized type itself when expansion is 3465 -- disabled, for ASIS use. 3466 3467 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3468 3469 Iface := First (Interface_List (N)); 3470 while Present (Iface) loop 3471 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 3472 3473 if not Is_Interface (Iface_Typ) then 3474 Error_Msg_NE 3475 ("(Ada 2005) & must be an interface", Iface, Iface_Typ); 3476 3477 else 3478 -- Ada 2005 (AI-251): "The declaration of a specific descendant 3479 -- of an interface type freezes the interface type" RM 13.14. 3480 3481 Freeze_Before (N, Etype (Iface)); 3482 3483 if Nkind (N) = N_Protected_Type_Declaration then 3484 3485 -- Ada 2005 (AI-345): Protected types can only implement 3486 -- limited, synchronized, or protected interfaces (note that 3487 -- the predicate Is_Limited_Interface includes synchronized 3488 -- and protected interfaces). 3489 3490 if Is_Task_Interface (Iface_Typ) then 3491 Error_Msg_N ("(Ada 2005) protected type cannot implement " 3492 & "a task interface", Iface); 3493 3494 elsif not Is_Limited_Interface (Iface_Typ) then 3495 Error_Msg_N ("(Ada 2005) protected type cannot implement " 3496 & "a non-limited interface", Iface); 3497 end if; 3498 3499 else pragma Assert (Nkind (N) = N_Task_Type_Declaration); 3500 3501 -- Ada 2005 (AI-345): Task types can only implement limited, 3502 -- synchronized, or task interfaces (note that the predicate 3503 -- Is_Limited_Interface includes synchronized and task 3504 -- interfaces). 3505 3506 if Is_Protected_Interface (Iface_Typ) then 3507 Error_Msg_N ("(Ada 2005) task type cannot implement a " & 3508 "protected interface", Iface); 3509 3510 elsif not Is_Limited_Interface (Iface_Typ) then 3511 Error_Msg_N ("(Ada 2005) task type cannot implement a " & 3512 "non-limited interface", Iface); 3513 end if; 3514 end if; 3515 end if; 3516 3517 Next (Iface); 3518 end loop; 3519 end if; 3520 3521 if not Has_Private_Declaration (T) then 3522 return; 3523 end if; 3524 3525 -- Additional checks on full-types associated with private type 3526 -- declarations. Search for the private type declaration. 3527 3528 declare 3529 Full_T_Ifaces : Elist_Id := No_Elist; 3530 Iface : Node_Id; 3531 Priv_T : Entity_Id; 3532 Priv_T_Ifaces : Elist_Id := No_Elist; 3533 3534 begin 3535 Priv_T := First_Entity (Scope (T)); 3536 loop 3537 pragma Assert (Present (Priv_T)); 3538 3539 if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then 3540 exit when Full_View (Priv_T) = T; 3541 end if; 3542 3543 Next_Entity (Priv_T); 3544 end loop; 3545 3546 -- In case of synchronized types covering interfaces the private type 3547 -- declaration must be limited. 3548 3549 if Present (Interface_List (N)) 3550 and then not Is_Limited_Type (Priv_T) 3551 then 3552 Error_Msg_Sloc := Sloc (Priv_T); 3553 Error_Msg_N ("(Ada 2005) limited type declaration expected for " & 3554 "private type#", T); 3555 end if; 3556 3557 -- RM 7.3 (7.1/2): If the full view has a partial view that is 3558 -- tagged then check RM 7.3 subsidiary rules. 3559 3560 if Is_Tagged_Type (Priv_T) 3561 and then not Error_Posted (N) 3562 then 3563 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged 3564 -- type if and only if the full type is a synchronized tagged type 3565 3566 if Is_Synchronized_Tagged_Type (Priv_T) 3567 and then not Is_Synchronized_Tagged_Type (T) 3568 then 3569 Error_Msg_N 3570 ("(Ada 2005) full view must be a synchronized tagged " & 3571 "type (RM 7.3 (7.2/2))", Priv_T); 3572 3573 elsif Is_Synchronized_Tagged_Type (T) 3574 and then not Is_Synchronized_Tagged_Type (Priv_T) 3575 then 3576 Error_Msg_N 3577 ("(Ada 2005) partial view must be a synchronized tagged " & 3578 "type (RM 7.3 (7.2/2))", T); 3579 end if; 3580 3581 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an 3582 -- interface type if and only if the full type is descendant of 3583 -- the interface type. 3584 3585 if Present (Interface_List (N)) 3586 or else (Is_Tagged_Type (Priv_T) 3587 and then Has_Interfaces 3588 (Priv_T, Use_Full_View => False)) 3589 then 3590 if Is_Tagged_Type (Priv_T) then 3591 Collect_Interfaces 3592 (Priv_T, Priv_T_Ifaces, Use_Full_View => False); 3593 end if; 3594 3595 if Is_Tagged_Type (T) then 3596 Collect_Interfaces (T, Full_T_Ifaces); 3597 end if; 3598 3599 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); 3600 3601 if Present (Iface) then 3602 Error_Msg_NE 3603 ("interface in partial view& not implemented by full " 3604 & "type (RM-2005 7.3 (7.3/2))", T, Iface); 3605 end if; 3606 3607 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); 3608 3609 if Present (Iface) then 3610 Error_Msg_NE 3611 ("interface & not implemented by partial " & 3612 "view (RM-2005 7.3 (7.3/2))", T, Iface); 3613 end if; 3614 end if; 3615 end if; 3616 end; 3617 end Check_Interfaces; 3618 3619 -------------------------------- 3620 -- Check_Triggering_Statement -- 3621 -------------------------------- 3622 3623 procedure Check_Triggering_Statement 3624 (Trigger : Node_Id; 3625 Error_Node : Node_Id; 3626 Is_Dispatching : out Boolean) 3627 is 3628 Param : Node_Id; 3629 3630 begin 3631 Is_Dispatching := False; 3632 3633 -- It is not possible to have a dispatching trigger if we are not in 3634 -- Ada 2005 mode. 3635 3636 if Ada_Version >= Ada_2005 3637 and then Nkind (Trigger) = N_Procedure_Call_Statement 3638 and then Present (Parameter_Associations (Trigger)) 3639 then 3640 Param := First (Parameter_Associations (Trigger)); 3641 3642 if Is_Controlling_Actual (Param) 3643 and then Is_Interface (Etype (Param)) 3644 then 3645 if Is_Limited_Record (Etype (Param)) then 3646 Is_Dispatching := True; 3647 else 3648 Error_Msg_N 3649 ("dispatching operation of limited or synchronized " & 3650 "interface required (RM 9.7.2(3))!", Error_Node); 3651 end if; 3652 3653 elsif Nkind (Trigger) = N_Explicit_Dereference then 3654 Error_Msg_N 3655 ("entry call or dispatching primitive of interface required ", 3656 Trigger); 3657 end if; 3658 end if; 3659 end Check_Triggering_Statement; 3660 3661 -------------------------- 3662 -- Find_Concurrent_Spec -- 3663 -------------------------- 3664 3665 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is 3666 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id); 3667 3668 begin 3669 -- The type may have been given by an incomplete type declaration. 3670 -- Find full view now. 3671 3672 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then 3673 Spec_Id := Full_View (Spec_Id); 3674 end if; 3675 3676 return Spec_Id; 3677 end Find_Concurrent_Spec; 3678 3679 -------------------------- 3680 -- Install_Declarations -- 3681 -------------------------- 3682 3683 procedure Install_Declarations (Spec : Entity_Id) is 3684 E : Entity_Id; 3685 Prev : Entity_Id; 3686 begin 3687 E := First_Entity (Spec); 3688 while Present (E) loop 3689 Prev := Current_Entity (E); 3690 Set_Current_Entity (E); 3691 Set_Is_Immediately_Visible (E); 3692 Set_Homonym (E, Prev); 3693 Next_Entity (E); 3694 end loop; 3695 end Install_Declarations; 3696 3697end Sem_Ch9; 3698