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