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