1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P A R . C H 9 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2011, 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 26pragma Style_Checks (All_Checks); 27-- Turn off subprogram body ordering check. Subprograms are in order by RM 28-- section rather than alphabetical. 29 30separate (Par) 31package body Ch9 is 32 33 -- Local subprograms, used only in this chapter 34 35 function P_Accept_Alternative return Node_Id; 36 function P_Delay_Alternative return Node_Id; 37 function P_Delay_Relative_Statement return Node_Id; 38 function P_Delay_Until_Statement return Node_Id; 39 function P_Entry_Barrier return Node_Id; 40 function P_Entry_Body_Formal_Part return Node_Id; 41 function P_Entry_Declaration return Node_Id; 42 function P_Entry_Index_Specification return Node_Id; 43 function P_Protected_Definition return Node_Id; 44 function P_Protected_Operation_Declaration_Opt return Node_Id; 45 function P_Protected_Operation_Items return List_Id; 46 function P_Task_Items return List_Id; 47 function P_Task_Definition return Node_Id; 48 49 ----------------------------- 50 -- 9.1 Task (also 10.1.3) -- 51 ----------------------------- 52 53 -- TASK_TYPE_DECLARATION ::= 54 -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] 55 -- [ASPECT_SPECIFICATIONS] 56 -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; 57 58 -- SINGLE_TASK_DECLARATION ::= 59 -- task DEFINING_IDENTIFIER 60 -- [ASPECT_SPECIFICATIONS] 61 -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; 62 63 -- TASK_BODY ::= 64 -- task body DEFINING_IDENTIFIER is 65 -- DECLARATIVE_PART 66 -- begin 67 -- HANDLED_SEQUENCE_OF_STATEMENTS 68 -- end [task_IDENTIFIER] 69 70 -- TASK_BODY_STUB ::= 71 -- task body DEFINING_IDENTIFIER is separate; 72 73 -- This routine scans out a task declaration, task body, or task stub 74 75 -- The caller has checked that the initial token is TASK and scanned 76 -- past it, so that Token is set to the token after TASK 77 78 -- Error recovery: cannot raise Error_Resync 79 80 function P_Task return Node_Id is 81 Name_Node : Node_Id; 82 Task_Node : Node_Id; 83 Task_Sloc : Source_Ptr; 84 85 begin 86 Push_Scope_Stack; 87 Scope.Table (Scope.Last).Etyp := E_Name; 88 Scope.Table (Scope.Last).Ecol := Start_Column; 89 Scope.Table (Scope.Last).Sloc := Token_Ptr; 90 Scope.Table (Scope.Last).Lreq := False; 91 Task_Sloc := Prev_Token_Ptr; 92 93 if Token = Tok_Body then 94 Scan; -- past BODY 95 Name_Node := P_Defining_Identifier (C_Is); 96 Scope.Table (Scope.Last).Labl := Name_Node; 97 98 if Token = Tok_Left_Paren then 99 Error_Msg_SC ("discriminant part not allowed in task body"); 100 Discard_Junk_List (P_Known_Discriminant_Part_Opt); 101 end if; 102 103 TF_Is; 104 105 -- Task stub 106 107 if Token = Tok_Separate then 108 Scan; -- past SEPARATE 109 Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc); 110 Set_Defining_Identifier (Task_Node, Name_Node); 111 TF_Semicolon; 112 Pop_Scope_Stack; -- remove unused entry 113 114 -- Task body 115 116 else 117 Task_Node := New_Node (N_Task_Body, Task_Sloc); 118 Set_Defining_Identifier (Task_Node, Name_Node); 119 Parse_Decls_Begin_End (Task_Node); 120 end if; 121 122 return Task_Node; 123 124 -- Otherwise we must have a task declaration 125 126 else 127 if Token = Tok_Type then 128 Scan; -- past TYPE 129 Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc); 130 Name_Node := P_Defining_Identifier; 131 Set_Defining_Identifier (Task_Node, Name_Node); 132 Scope.Table (Scope.Last).Labl := Name_Node; 133 Set_Discriminant_Specifications 134 (Task_Node, P_Known_Discriminant_Part_Opt); 135 136 else 137 Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc); 138 Name_Node := P_Defining_Identifier (C_Is); 139 Set_Defining_Identifier (Task_Node, Name_Node); 140 Scope.Table (Scope.Last).Labl := Name_Node; 141 142 if Token = Tok_Left_Paren then 143 Error_Msg_SC ("discriminant part not allowed for single task"); 144 Discard_Junk_List (P_Known_Discriminant_Part_Opt); 145 end if; 146 end if; 147 148 -- Scan aspect specifications, don't eat the semicolon, since it 149 -- might not be there if we have an IS. 150 151 P_Aspect_Specifications (Task_Node, Semicolon => False); 152 153 -- Parse optional task definition. Note that P_Task_Definition scans 154 -- out the semicolon and possible aspect specifications as well as 155 -- the task definition itself. 156 157 if Token = Tok_Semicolon then 158 159 -- A little check, if the next token after semicolon is Entry, 160 -- then surely the semicolon should really be IS 161 162 Scan; -- past semicolon 163 164 if Token = Tok_Entry then 165 Error_Msg_SP -- CODEFIX 166 ("|"";"" should be IS"); 167 Set_Task_Definition (Task_Node, P_Task_Definition); 168 else 169 Pop_Scope_Stack; -- Remove unused entry 170 end if; 171 172 -- Here we have a task definition 173 174 else 175 TF_Is; -- must have IS if no semicolon 176 177 -- Ada 2005 (AI-345) 178 179 if Token = Tok_New then 180 Scan; -- past NEW 181 182 if Ada_Version < Ada_2005 then 183 Error_Msg_SP ("task interface is an Ada 2005 extension"); 184 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 185 end if; 186 187 Set_Interface_List (Task_Node, New_List); 188 189 loop 190 Append (P_Qualified_Simple_Name, Interface_List (Task_Node)); 191 exit when Token /= Tok_And; 192 Scan; -- past AND 193 end loop; 194 195 if Token /= Tok_With then 196 Error_Msg_SC -- CODEFIX 197 ("WITH expected"); 198 end if; 199 200 Scan; -- past WITH 201 202 if Token = Tok_Private then 203 Error_Msg_SP -- CODEFIX 204 ("PRIVATE not allowed in task type declaration"); 205 end if; 206 end if; 207 208 Set_Task_Definition (Task_Node, P_Task_Definition); 209 end if; 210 211 return Task_Node; 212 end if; 213 end P_Task; 214 215 -------------------------------- 216 -- 9.1 Task Type Declaration -- 217 -------------------------------- 218 219 -- Parsed by P_Task (9.1) 220 221 ---------------------------------- 222 -- 9.1 Single Task Declaration -- 223 ---------------------------------- 224 225 -- Parsed by P_Task (9.1) 226 227 -------------------------- 228 -- 9.1 Task Definition -- 229 -------------------------- 230 231 -- TASK_DEFINITION ::= 232 -- {TASK_ITEM} 233 -- [private 234 -- {TASK_ITEM}] 235 -- end [task_IDENTIFIER]; 236 237 -- The caller has already made the scope stack entry 238 239 -- Note: there is a small deviation from official syntax here in that we 240 -- regard the semicolon after end as part of the Task_Definition, and in 241 -- the official syntax, it's part of the enclosing declaration. The reason 242 -- for this deviation is that otherwise the end processing would have to 243 -- be special cased, which would be a nuisance! 244 245 -- Error recovery: cannot raise Error_Resync 246 247 function P_Task_Definition return Node_Id is 248 Def_Node : Node_Id; 249 250 begin 251 Def_Node := New_Node (N_Task_Definition, Token_Ptr); 252 Set_Visible_Declarations (Def_Node, P_Task_Items); 253 254 if Token = Tok_Private then 255 Scan; -- past PRIVATE 256 Set_Private_Declarations (Def_Node, P_Task_Items); 257 258 -- Deal gracefully with multiple PRIVATE parts 259 260 while Token = Tok_Private loop 261 Error_Msg_SC ("only one private part allowed per task"); 262 Scan; -- past PRIVATE 263 Append_List (P_Task_Items, Private_Declarations (Def_Node)); 264 end loop; 265 end if; 266 267 End_Statements (Def_Node); 268 return Def_Node; 269 end P_Task_Definition; 270 271 -------------------- 272 -- 9.1 Task Item -- 273 -------------------- 274 275 -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE 276 277 -- This subprogram scans a (possibly empty) list of task items and pragmas 278 279 -- Error recovery: cannot raise Error_Resync 280 281 -- Note: a pragma can also be returned in this position 282 283 function P_Task_Items return List_Id is 284 Items : List_Id; 285 Item_Node : Node_Id; 286 Decl_Sloc : Source_Ptr; 287 288 begin 289 -- Get rid of active SIS entry from outer scope. This means we will 290 -- miss some nested cases, but it doesn't seem worth the effort. See 291 -- discussion in Par for further details 292 293 SIS_Entry_Active := False; 294 295 -- Loop to scan out task items 296 297 Items := New_List; 298 299 Decl_Loop : loop 300 Decl_Sloc := Token_Ptr; 301 302 if Token = Tok_Pragma then 303 Append (P_Pragma, Items); 304 305 -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING 306 -- may begin an entry declaration. 307 308 elsif Token = Tok_Entry 309 or else Token = Tok_Not 310 or else Token = Tok_Overriding 311 then 312 Append (P_Entry_Declaration, Items); 313 314 elsif Token = Tok_For then 315 -- Representation clause in task declaration. The only rep 316 -- clause which is legal in a protected is an address clause, 317 -- so that is what we try to scan out. 318 319 Item_Node := P_Representation_Clause; 320 321 if Nkind (Item_Node) = N_At_Clause then 322 Append (Item_Node, Items); 323 324 elsif Nkind (Item_Node) = N_Attribute_Definition_Clause 325 and then Chars (Item_Node) = Name_Address 326 then 327 Append (Item_Node, Items); 328 329 else 330 Error_Msg 331 ("the only representation clause " & 332 "allowed here is an address clause!", Decl_Sloc); 333 end if; 334 335 elsif Token = Tok_Identifier 336 or else Token in Token_Class_Declk 337 then 338 Error_Msg_SC ("illegal declaration in task definition"); 339 Resync_Past_Semicolon; 340 341 else 342 exit Decl_Loop; 343 end if; 344 end loop Decl_Loop; 345 346 return Items; 347 end P_Task_Items; 348 349 -------------------- 350 -- 9.1 Task Body -- 351 -------------------- 352 353 -- Parsed by P_Task (9.1) 354 355 ---------------------------------- 356 -- 9.4 Protected (also 10.1.3) -- 357 ---------------------------------- 358 359 -- PROTECTED_TYPE_DECLARATION ::= 360 -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] 361 -- [ASPECT_SPECIFICATIONS] 362 -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; 363 364 -- SINGLE_PROTECTED_DECLARATION ::= 365 -- protected DEFINING_IDENTIFIER 366 -- [ASPECT_SPECIFICATIONS] 367 -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; 368 369 -- PROTECTED_BODY ::= 370 -- protected body DEFINING_IDENTIFIER is 371 -- {PROTECTED_OPERATION_ITEM} 372 -- end [protected_IDENTIFIER]; 373 374 -- PROTECTED_BODY_STUB ::= 375 -- protected body DEFINING_IDENTIFIER is separate; 376 377 -- This routine scans out a protected declaration, protected body 378 -- or a protected stub. 379 380 -- The caller has checked that the initial token is PROTECTED and 381 -- scanned past it, so Token is set to the following token. 382 383 -- Error recovery: cannot raise Error_Resync 384 385 function P_Protected return Node_Id is 386 Name_Node : Node_Id; 387 Protected_Node : Node_Id; 388 Protected_Sloc : Source_Ptr; 389 Scan_State : Saved_Scan_State; 390 391 begin 392 Push_Scope_Stack; 393 Scope.Table (Scope.Last).Etyp := E_Name; 394 Scope.Table (Scope.Last).Ecol := Start_Column; 395 Scope.Table (Scope.Last).Lreq := False; 396 Protected_Sloc := Prev_Token_Ptr; 397 398 if Token = Tok_Body then 399 Scan; -- past BODY 400 Name_Node := P_Defining_Identifier (C_Is); 401 Scope.Table (Scope.Last).Labl := Name_Node; 402 403 if Token = Tok_Left_Paren then 404 Error_Msg_SC ("discriminant part not allowed in protected body"); 405 Discard_Junk_List (P_Known_Discriminant_Part_Opt); 406 end if; 407 408 TF_Is; 409 410 -- Protected stub 411 412 if Token = Tok_Separate then 413 Scan; -- past SEPARATE 414 Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc); 415 Set_Defining_Identifier (Protected_Node, Name_Node); 416 TF_Semicolon; 417 Pop_Scope_Stack; -- remove unused entry 418 419 -- Protected body 420 421 else 422 Protected_Node := New_Node (N_Protected_Body, Protected_Sloc); 423 Set_Defining_Identifier (Protected_Node, Name_Node); 424 Set_Declarations (Protected_Node, P_Protected_Operation_Items); 425 End_Statements (Protected_Node); 426 end if; 427 428 return Protected_Node; 429 430 -- Otherwise we must have a protected declaration 431 432 else 433 if Token = Tok_Type then 434 Scan; -- past TYPE 435 Protected_Node := 436 New_Node (N_Protected_Type_Declaration, Protected_Sloc); 437 Name_Node := P_Defining_Identifier (C_Is); 438 Set_Defining_Identifier (Protected_Node, Name_Node); 439 Scope.Table (Scope.Last).Labl := Name_Node; 440 Set_Discriminant_Specifications 441 (Protected_Node, P_Known_Discriminant_Part_Opt); 442 443 else 444 Protected_Node := 445 New_Node (N_Single_Protected_Declaration, Protected_Sloc); 446 Name_Node := P_Defining_Identifier (C_Is); 447 Set_Defining_Identifier (Protected_Node, Name_Node); 448 449 if Token = Tok_Left_Paren then 450 Error_Msg_SC 451 ("discriminant part not allowed for single protected"); 452 Discard_Junk_List (P_Known_Discriminant_Part_Opt); 453 end if; 454 455 Scope.Table (Scope.Last).Labl := Name_Node; 456 end if; 457 458 P_Aspect_Specifications (Protected_Node, Semicolon => False); 459 460 -- Check for semicolon not followed by IS, this is something like 461 462 -- protected type r; 463 464 -- where we want 465 466 -- protected type r IS END; 467 468 if Token = Tok_Semicolon then 469 Save_Scan_State (Scan_State); -- at semicolon 470 Scan; -- past semicolon 471 472 if Token /= Tok_Is then 473 Restore_Scan_State (Scan_State); 474 Error_Msg_SC -- CODEFIX 475 ("missing IS"); 476 Set_Protected_Definition (Protected_Node, 477 Make_Protected_Definition (Token_Ptr, 478 Visible_Declarations => Empty_List, 479 End_Label => Empty)); 480 481 SIS_Entry_Active := False; 482 End_Statements 483 (Protected_Definition (Protected_Node), Protected_Node); 484 return Protected_Node; 485 end if; 486 487 Error_Msg_SP -- CODEFIX 488 ("|extra ""("" ignored"); 489 end if; 490 491 T_Is; 492 493 -- Ada 2005 (AI-345) 494 495 if Token = Tok_New then 496 Scan; -- past NEW 497 498 if Ada_Version < Ada_2005 then 499 Error_Msg_SP ("protected interface is an Ada 2005 extension"); 500 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 501 end if; 502 503 Set_Interface_List (Protected_Node, New_List); 504 505 loop 506 Append (P_Qualified_Simple_Name, 507 Interface_List (Protected_Node)); 508 509 exit when Token /= Tok_And; 510 Scan; -- past AND 511 end loop; 512 513 if Token /= Tok_With then 514 Error_Msg_SC -- CODEFIX 515 ("WITH expected"); 516 end if; 517 518 Scan; -- past WITH 519 end if; 520 521 Set_Protected_Definition (Protected_Node, P_Protected_Definition); 522 return Protected_Node; 523 end if; 524 end P_Protected; 525 526 ------------------------------------- 527 -- 9.4 Protected Type Declaration -- 528 ------------------------------------- 529 530 -- Parsed by P_Protected (9.4) 531 532 --------------------------------------- 533 -- 9.4 Single Protected Declaration -- 534 --------------------------------------- 535 536 -- Parsed by P_Protected (9.4) 537 538 ------------------------------- 539 -- 9.4 Protected Definition -- 540 ------------------------------- 541 542 -- PROTECTED_DEFINITION ::= 543 -- {PROTECTED_OPERATION_DECLARATION} 544 -- [private 545 -- {PROTECTED_ELEMENT_DECLARATION}] 546 -- end [protected_IDENTIFIER] 547 548 -- PROTECTED_ELEMENT_DECLARATION ::= 549 -- PROTECTED_OPERATION_DECLARATION 550 -- | COMPONENT_DECLARATION 551 552 -- The caller has already established the scope stack entry 553 554 -- Error recovery: cannot raise Error_Resync 555 556 function P_Protected_Definition return Node_Id is 557 Def_Node : Node_Id; 558 Item_Node : Node_Id; 559 560 begin 561 Def_Node := New_Node (N_Protected_Definition, Token_Ptr); 562 563 -- Get rid of active SIS entry from outer scope. This means we will 564 -- miss some nested cases, but it doesn't seem worth the effort. See 565 -- discussion in Par for further details 566 567 SIS_Entry_Active := False; 568 569 -- Loop to scan visible declarations (protected operation declarations) 570 571 Set_Visible_Declarations (Def_Node, New_List); 572 573 loop 574 Item_Node := P_Protected_Operation_Declaration_Opt; 575 exit when No (Item_Node); 576 Append (Item_Node, Visible_Declarations (Def_Node)); 577 end loop; 578 579 -- Deal with PRIVATE part (including graceful handling of multiple 580 -- PRIVATE parts). 581 582 Private_Loop : while Token = Tok_Private loop 583 if No (Private_Declarations (Def_Node)) then 584 Set_Private_Declarations (Def_Node, New_List); 585 else 586 Error_Msg_SC ("duplicate private part"); 587 end if; 588 589 Scan; -- past PRIVATE 590 591 Declaration_Loop : loop 592 if Token = Tok_Identifier then 593 P_Component_Items (Private_Declarations (Def_Node)); 594 else 595 Item_Node := P_Protected_Operation_Declaration_Opt; 596 exit Declaration_Loop when No (Item_Node); 597 Append (Item_Node, Private_Declarations (Def_Node)); 598 end if; 599 end loop Declaration_Loop; 600 end loop Private_Loop; 601 602 End_Statements (Def_Node); 603 return Def_Node; 604 end P_Protected_Definition; 605 606 ------------------------------------------ 607 -- 9.4 Protected Operation Declaration -- 608 ------------------------------------------ 609 610 -- PROTECTED_OPERATION_DECLARATION ::= 611 -- SUBPROGRAM_DECLARATION 612 -- | ENTRY_DECLARATION 613 -- | REPRESENTATION_CLAUSE 614 615 -- Error recovery: cannot raise Error_Resync 616 617 -- Note: a pragma can also be returned in this position 618 619 -- We are not currently permitting representation clauses to appear as 620 -- protected operation declarations, do we have to rethink this??? 621 622 function P_Protected_Operation_Declaration_Opt return Node_Id is 623 L : List_Id; 624 P : Source_Ptr; 625 626 function P_Entry_Or_Subprogram_With_Indicator return Node_Id; 627 -- Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding 628 -- indicator. The caller has checked that the initial token is NOT or 629 -- OVERRIDING. 630 631 ------------------------------------------ 632 -- P_Entry_Or_Subprogram_With_Indicator -- 633 ------------------------------------------ 634 635 function P_Entry_Or_Subprogram_With_Indicator return Node_Id is 636 Decl : Node_Id := Error; 637 Is_Overriding : Boolean := False; 638 Not_Overriding : Boolean := False; 639 640 begin 641 if Token = Tok_Not then 642 Scan; -- past NOT 643 644 if Token = Tok_Overriding then 645 Scan; -- past OVERRIDING 646 Not_Overriding := True; 647 else 648 Error_Msg_SC -- CODEFIX 649 ("OVERRIDING expected!"); 650 end if; 651 652 else 653 Scan; -- past OVERRIDING 654 Is_Overriding := True; 655 end if; 656 657 if Is_Overriding or else Not_Overriding then 658 if Ada_Version < Ada_2005 then 659 Error_Msg_SP ("overriding indicator is an Ada 2005 extension"); 660 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 661 662 elsif Token = Tok_Entry then 663 Decl := P_Entry_Declaration; 664 665 Set_Must_Override (Decl, Is_Overriding); 666 Set_Must_Not_Override (Decl, Not_Overriding); 667 668 elsif Token = Tok_Function or else Token = Tok_Procedure then 669 Decl := P_Subprogram (Pf_Decl_Pexp); 670 671 Set_Must_Override (Specification (Decl), Is_Overriding); 672 Set_Must_Not_Override (Specification (Decl), Not_Overriding); 673 674 else 675 Error_Msg_SC -- CODEFIX 676 ("ENTRY, FUNCTION or PROCEDURE expected!"); 677 end if; 678 end if; 679 680 return Decl; 681 end P_Entry_Or_Subprogram_With_Indicator; 682 683 -- Start of processing for P_Protected_Operation_Declaration_Opt 684 685 begin 686 -- This loop runs more than once only when a junk declaration 687 -- is skipped. 688 689 loop 690 if Token = Tok_Pragma then 691 return P_Pragma; 692 693 elsif Token = Tok_Not or else Token = Tok_Overriding then 694 return P_Entry_Or_Subprogram_With_Indicator; 695 696 elsif Token = Tok_Entry then 697 return P_Entry_Declaration; 698 699 elsif Token = Tok_Function or else Token = Tok_Procedure then 700 return P_Subprogram (Pf_Decl_Pexp); 701 702 elsif Token = Tok_Identifier then 703 L := New_List; 704 P := Token_Ptr; 705 Skip_Declaration (L); 706 707 if Nkind (First (L)) = N_Object_Declaration then 708 Error_Msg 709 ("component must be declared in private part of " & 710 "protected type", P); 711 else 712 Error_Msg 713 ("illegal declaration in protected definition", P); 714 end if; 715 716 elsif Token in Token_Class_Declk then 717 Error_Msg_SC ("illegal declaration in protected definition"); 718 Resync_Past_Semicolon; 719 720 -- Return now to avoid cascaded messages if next declaration 721 -- is a valid component declaration. 722 723 return Error; 724 725 elsif Token = Tok_For then 726 Error_Msg_SC 727 ("representation clause not allowed in protected definition"); 728 Resync_Past_Semicolon; 729 730 else 731 return Empty; 732 end if; 733 end loop; 734 end P_Protected_Operation_Declaration_Opt; 735 736 ----------------------------------- 737 -- 9.4 Protected Operation Item -- 738 ----------------------------------- 739 740 -- PROTECTED_OPERATION_ITEM ::= 741 -- SUBPROGRAM_DECLARATION 742 -- | SUBPROGRAM_BODY 743 -- | ENTRY_BODY 744 -- | REPRESENTATION_CLAUSE 745 746 -- This procedure parses and returns a list of protected operation items 747 748 -- We are not currently permitting representation clauses to appear 749 -- as protected operation items, do we have to rethink this??? 750 751 function P_Protected_Operation_Items return List_Id is 752 Item_List : List_Id; 753 754 begin 755 Item_List := New_List; 756 757 loop 758 if Token = Tok_Entry or else Bad_Spelling_Of (Tok_Entry) then 759 Append (P_Entry_Body, Item_List); 760 761 -- If the operation starts with procedure, function, or an overriding 762 -- indicator ("overriding" or "not overriding"), parse a subprogram. 763 764 elsif Token = Tok_Function or else Bad_Spelling_Of (Tok_Function) 765 or else 766 Token = Tok_Procedure or else Bad_Spelling_Of (Tok_Procedure) 767 or else 768 Token = Tok_Overriding or else Bad_Spelling_Of (Tok_Overriding) 769 or else 770 Token = Tok_Not or else Bad_Spelling_Of (Tok_Not) 771 then 772 Append (P_Subprogram (Pf_Decl_Pbod_Pexp), Item_List); 773 774 elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then 775 P_Pragmas_Opt (Item_List); 776 777 elsif Token = Tok_Private or else Bad_Spelling_Of (Tok_Private) then 778 Error_Msg_SC ("PRIVATE not allowed in protected body"); 779 Scan; -- past PRIVATE 780 781 elsif Token = Tok_Identifier then 782 Error_Msg_SC ("all components must be declared in spec!"); 783 Resync_Past_Semicolon; 784 785 elsif Token in Token_Class_Declk then 786 Error_Msg_SC ("this declaration not allowed in protected body"); 787 Resync_Past_Semicolon; 788 789 else 790 exit; 791 end if; 792 end loop; 793 794 return Item_List; 795 end P_Protected_Operation_Items; 796 797 ------------------------------ 798 -- 9.5.2 Entry Declaration -- 799 ------------------------------ 800 801 -- ENTRY_DECLARATION ::= 802 -- [OVERRIDING_INDICATOR] 803 -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)] 804 -- PARAMETER_PROFILE; 805 -- [ASPECT_SPECIFICATIONS]; 806 807 -- The caller has checked that the initial token is ENTRY, NOT or 808 -- OVERRIDING. 809 810 -- Error recovery: cannot raise Error_Resync 811 812 function P_Entry_Declaration return Node_Id is 813 Decl_Node : Node_Id; 814 Scan_State : Saved_Scan_State; 815 816 -- Flags for optional overriding indication. Two flags are needed, 817 -- to distinguish positive and negative overriding indicators from 818 -- the absence of any indicator. 819 820 Is_Overriding : Boolean := False; 821 Not_Overriding : Boolean := False; 822 823 begin 824 -- Ada 2005 (AI-397): Scan leading overriding indicator 825 826 if Token = Tok_Not then 827 Scan; -- past NOT 828 829 if Token = Tok_Overriding then 830 Scan; -- part OVERRIDING 831 Not_Overriding := True; 832 else 833 Error_Msg_SC -- CODEFIX 834 ("OVERRIDING expected!"); 835 end if; 836 837 elsif Token = Tok_Overriding then 838 Scan; -- part OVERRIDING 839 Is_Overriding := True; 840 end if; 841 842 if Is_Overriding or else Not_Overriding then 843 if Ada_Version < Ada_2005 then 844 Error_Msg_SP ("overriding indicator is an Ada 2005 extension"); 845 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 846 847 elsif Token /= Tok_Entry then 848 Error_Msg_SC -- CODEFIX 849 ("ENTRY expected!"); 850 end if; 851 end if; 852 853 Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr); 854 Scan; -- past ENTRY 855 856 Set_Defining_Identifier 857 (Decl_Node, P_Defining_Identifier (C_Left_Paren_Semicolon)); 858 859 -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part 860 861 if Token = Tok_Left_Paren then 862 Scan; -- past ( 863 864 -- If identifier after left paren, could still be either 865 866 if Token = Tok_Identifier then 867 Save_Scan_State (Scan_State); -- at Id 868 Scan; -- past Id 869 870 -- If comma or colon after Id, must be Formal_Part 871 872 if Token = Tok_Comma or else Token = Tok_Colon then 873 Restore_Scan_State (Scan_State); -- to Id 874 Set_Parameter_Specifications (Decl_Node, P_Formal_Part); 875 876 -- Else if Id without comma or colon, must be discrete subtype 877 -- defn 878 879 else 880 Restore_Scan_State (Scan_State); -- to Id 881 Set_Discrete_Subtype_Definition 882 (Decl_Node, P_Discrete_Subtype_Definition); 883 T_Right_Paren; 884 Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile); 885 end if; 886 887 -- If no Id, must be discrete subtype definition 888 889 else 890 Set_Discrete_Subtype_Definition 891 (Decl_Node, P_Discrete_Subtype_Definition); 892 T_Right_Paren; 893 Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile); 894 end if; 895 end if; 896 897 if Is_Overriding then 898 Set_Must_Override (Decl_Node); 899 elsif Not_Overriding then 900 Set_Must_Not_Override (Decl_Node); 901 end if; 902 903 -- Error recovery check for illegal return 904 905 if Token = Tok_Return then 906 Error_Msg_SC ("entry cannot have return value!"); 907 Scan; 908 Discard_Junk_Node (P_Subtype_Indication); 909 end if; 910 911 -- Error recovery check for improper use of entry barrier in spec 912 913 if Token = Tok_When then 914 Error_Msg_SC ("barrier not allowed here (belongs in body)"); 915 Scan; -- past WHEN; 916 Discard_Junk_Node (P_Expression_No_Right_Paren); 917 end if; 918 919 P_Aspect_Specifications (Decl_Node); 920 return Decl_Node; 921 922 exception 923 when Error_Resync => 924 Resync_Past_Semicolon; 925 return Error; 926 end P_Entry_Declaration; 927 928 ----------------------------- 929 -- 9.5.2 Accept Statement -- 930 ----------------------------- 931 932 -- ACCEPT_STATEMENT ::= 933 -- accept entry_DIRECT_NAME 934 -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do 935 -- HANDLED_SEQUENCE_OF_STATEMENTS 936 -- end [entry_IDENTIFIER]]; 937 938 -- The caller has checked that the initial token is ACCEPT 939 940 -- Error recovery: cannot raise Error_Resync. If an error occurs, the 941 -- scan is resynchronized past the next semicolon and control returns. 942 943 function P_Accept_Statement return Node_Id is 944 Scan_State : Saved_Scan_State; 945 Accept_Node : Node_Id; 946 Hand_Seq : Node_Id; 947 948 begin 949 Push_Scope_Stack; 950 Scope.Table (Scope.Last).Sloc := Token_Ptr; 951 Scope.Table (Scope.Last).Ecol := Start_Column; 952 953 Accept_Node := New_Node (N_Accept_Statement, Token_Ptr); 954 Scan; -- past ACCEPT 955 Scope.Table (Scope.Last).Labl := Token_Node; 956 957 Set_Entry_Direct_Name (Accept_Node, P_Identifier (C_Do)); 958 959 -- Left paren could be (Entry_Index) or Formal_Part, determine which 960 961 if Token = Tok_Left_Paren then 962 Save_Scan_State (Scan_State); -- at left paren 963 Scan; -- past left paren 964 965 -- If first token after left paren not identifier, then Entry_Index 966 967 if Token /= Tok_Identifier then 968 Set_Entry_Index (Accept_Node, P_Expression); 969 T_Right_Paren; 970 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); 971 972 -- First token after left paren is identifier, could be either case 973 974 else -- Token = Tok_Identifier 975 Scan; -- past identifier 976 977 -- If identifier followed by comma or colon, must be Formal_Part 978 979 if Token = Tok_Comma or else Token = Tok_Colon then 980 Restore_Scan_State (Scan_State); -- to left paren 981 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); 982 983 -- If identifier not followed by comma/colon, must be entry index 984 985 else 986 Restore_Scan_State (Scan_State); -- to left paren 987 Scan; -- past left paren (again!) 988 Set_Entry_Index (Accept_Node, P_Expression); 989 T_Right_Paren; 990 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); 991 end if; 992 end if; 993 end if; 994 995 -- Scan out DO if present 996 997 if Token = Tok_Do then 998 Scope.Table (Scope.Last).Etyp := E_Name; 999 Scope.Table (Scope.Last).Lreq := False; 1000 Scan; -- past DO 1001 Hand_Seq := P_Handled_Sequence_Of_Statements; 1002 Set_Handled_Statement_Sequence (Accept_Node, Hand_Seq); 1003 End_Statements (Handled_Statement_Sequence (Accept_Node)); 1004 1005 -- Exception handlers not allowed in Ada 95 node 1006 1007 if Present (Exception_Handlers (Hand_Seq)) then 1008 if Ada_Version = Ada_83 then 1009 Error_Msg_N 1010 ("(Ada 83) exception handlers in accept not allowed", 1011 First_Non_Pragma (Exception_Handlers (Hand_Seq))); 1012 end if; 1013 end if; 1014 1015 else 1016 Pop_Scope_Stack; -- discard unused entry 1017 TF_Semicolon; 1018 end if; 1019 1020 return Accept_Node; 1021 1022 -- If error, resynchronize past semicolon 1023 1024 exception 1025 when Error_Resync => 1026 Resync_Past_Semicolon; 1027 Pop_Scope_Stack; -- discard unused entry 1028 return Error; 1029 1030 end P_Accept_Statement; 1031 1032 ------------------------ 1033 -- 9.5.2 Entry Index -- 1034 ------------------------ 1035 1036 -- Parsed by P_Expression (4.4) 1037 1038 ----------------------- 1039 -- 9.5.2 Entry Body -- 1040 ----------------------- 1041 1042 -- ENTRY_BODY ::= 1043 -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is 1044 -- DECLARATIVE_PART 1045 -- begin 1046 -- HANDLED_SEQUENCE_OF_STATEMENTS 1047 -- end [entry_IDENTIFIER]; 1048 1049 -- The caller has checked that the initial token is ENTRY 1050 1051 -- Error_Recovery: cannot raise Error_Resync 1052 1053 function P_Entry_Body return Node_Id is 1054 Entry_Node : Node_Id; 1055 Formal_Part_Node : Node_Id; 1056 Name_Node : Node_Id; 1057 1058 begin 1059 Push_Scope_Stack; 1060 Entry_Node := New_Node (N_Entry_Body, Token_Ptr); 1061 Scan; -- past ENTRY 1062 1063 Scope.Table (Scope.Last).Ecol := Start_Column; 1064 Scope.Table (Scope.Last).Lreq := False; 1065 Scope.Table (Scope.Last).Etyp := E_Name; 1066 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1067 1068 Name_Node := P_Defining_Identifier; 1069 Set_Defining_Identifier (Entry_Node, Name_Node); 1070 Scope.Table (Scope.Last).Labl := Name_Node; 1071 1072 Formal_Part_Node := P_Entry_Body_Formal_Part; 1073 Set_Entry_Body_Formal_Part (Entry_Node, Formal_Part_Node); 1074 1075 Set_Condition (Formal_Part_Node, P_Entry_Barrier); 1076 Parse_Decls_Begin_End (Entry_Node); 1077 return Entry_Node; 1078 end P_Entry_Body; 1079 1080 ----------------------------------- 1081 -- 9.5.2 Entry Body Formal Part -- 1082 ----------------------------------- 1083 1084 -- ENTRY_BODY_FORMAL_PART ::= 1085 -- [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART] 1086 1087 -- Error_Recovery: cannot raise Error_Resync 1088 1089 function P_Entry_Body_Formal_Part return Node_Id is 1090 Fpart_Node : Node_Id; 1091 Scan_State : Saved_Scan_State; 1092 1093 begin 1094 Fpart_Node := New_Node (N_Entry_Body_Formal_Part, Token_Ptr); 1095 1096 -- See if entry index specification present, and if so parse it 1097 1098 if Token = Tok_Left_Paren then 1099 Save_Scan_State (Scan_State); -- at left paren 1100 Scan; -- past left paren 1101 1102 if Token = Tok_For then 1103 Set_Entry_Index_Specification 1104 (Fpart_Node, P_Entry_Index_Specification); 1105 T_Right_Paren; 1106 else 1107 Restore_Scan_State (Scan_State); -- to left paren 1108 end if; 1109 1110 -- Check for (common?) case of left paren omitted before FOR. This 1111 -- is a tricky case, because the corresponding missing left paren 1112 -- can cause real havoc if a formal part is present which gets 1113 -- treated as part of the discrete subtype definition of the 1114 -- entry index specification, so just give error and resynchronize 1115 1116 elsif Token = Tok_For then 1117 T_Left_Paren; -- to give error message 1118 Resync_To_When; 1119 end if; 1120 1121 Set_Parameter_Specifications (Fpart_Node, P_Parameter_Profile); 1122 return Fpart_Node; 1123 end P_Entry_Body_Formal_Part; 1124 1125 -------------------------- 1126 -- 9.5.2 Entry Barrier -- 1127 -------------------------- 1128 1129 -- ENTRY_BARRIER ::= when CONDITION 1130 1131 -- Error_Recovery: cannot raise Error_Resync 1132 1133 function P_Entry_Barrier return Node_Id is 1134 Bnode : Node_Id; 1135 1136 begin 1137 if Token = Tok_When then 1138 Scan; -- past WHEN; 1139 Bnode := P_Expression_No_Right_Paren; 1140 1141 if Token = Tok_Colon_Equal then 1142 Error_Msg_SC -- CODEFIX 1143 ("|"":="" should be ""="""); 1144 Scan; 1145 Bnode := P_Expression_No_Right_Paren; 1146 end if; 1147 1148 else 1149 T_When; -- to give error message 1150 Bnode := Error; 1151 end if; 1152 1153 TF_Is; 1154 return Bnode; 1155 end P_Entry_Barrier; 1156 1157 -------------------------------------- 1158 -- 9.5.2 Entry Index Specification -- 1159 -------------------------------------- 1160 1161 -- ENTRY_INDEX_SPECIFICATION ::= 1162 -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION 1163 1164 -- Error recovery: can raise Error_Resync 1165 1166 function P_Entry_Index_Specification return Node_Id is 1167 Iterator_Node : Node_Id; 1168 1169 begin 1170 Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr); 1171 T_For; -- past FOR 1172 Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier (C_In)); 1173 T_In; 1174 Set_Discrete_Subtype_Definition 1175 (Iterator_Node, P_Discrete_Subtype_Definition); 1176 return Iterator_Node; 1177 end P_Entry_Index_Specification; 1178 1179 --------------------------------- 1180 -- 9.5.3 Entry Call Statement -- 1181 --------------------------------- 1182 1183 -- Parsed by P_Name (4.1). Within a select, an entry call is parsed 1184 -- by P_Select_Statement (9.7) 1185 1186 ------------------------------ 1187 -- 9.5.4 Requeue Statement -- 1188 ------------------------------ 1189 1190 -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort]; 1191 1192 -- The caller has checked that the initial token is requeue 1193 1194 -- Error recovery: can raise Error_Resync 1195 1196 function P_Requeue_Statement return Node_Id is 1197 Requeue_Node : Node_Id; 1198 1199 begin 1200 Requeue_Node := New_Node (N_Requeue_Statement, Token_Ptr); 1201 Scan; -- past REQUEUE 1202 Set_Name (Requeue_Node, P_Name); 1203 1204 if Token = Tok_With then 1205 Scan; -- past WITH 1206 T_Abort; 1207 Set_Abort_Present (Requeue_Node, True); 1208 end if; 1209 1210 TF_Semicolon; 1211 return Requeue_Node; 1212 end P_Requeue_Statement; 1213 1214 -------------------------- 1215 -- 9.6 Delay Statement -- 1216 -------------------------- 1217 1218 -- DELAY_STATEMENT ::= 1219 -- DELAY_UNTIL_STATEMENT 1220 -- | DELAY_RELATIVE_STATEMENT 1221 1222 -- The caller has checked that the initial token is DELAY 1223 1224 -- Error recovery: cannot raise Error_Resync 1225 1226 function P_Delay_Statement return Node_Id is 1227 begin 1228 Scan; -- past DELAY 1229 1230 -- The following check for delay until misused in Ada 83 doesn't catch 1231 -- all cases, but it's good enough to catch most of them! 1232 1233 if Token_Name = Name_Until then 1234 Check_95_Keyword (Tok_Until, Tok_Left_Paren); 1235 Check_95_Keyword (Tok_Until, Tok_Identifier); 1236 end if; 1237 1238 if Token = Tok_Until then 1239 return P_Delay_Until_Statement; 1240 else 1241 return P_Delay_Relative_Statement; 1242 end if; 1243 end P_Delay_Statement; 1244 1245 -------------------------------- 1246 -- 9.6 Delay Until Statement -- 1247 -------------------------------- 1248 1249 -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION; 1250 1251 -- The caller has checked that the initial token is DELAY, scanned it 1252 -- out and checked that the current token is UNTIL 1253 1254 -- Error recovery: cannot raise Error_Resync 1255 1256 function P_Delay_Until_Statement return Node_Id is 1257 Delay_Node : Node_Id; 1258 1259 begin 1260 Delay_Node := New_Node (N_Delay_Until_Statement, Prev_Token_Ptr); 1261 Scan; -- past UNTIL 1262 Set_Expression (Delay_Node, P_Expression_No_Right_Paren); 1263 TF_Semicolon; 1264 return Delay_Node; 1265 end P_Delay_Until_Statement; 1266 1267 ----------------------------------- 1268 -- 9.6 Delay Relative Statement -- 1269 ----------------------------------- 1270 1271 -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION; 1272 1273 -- The caller has checked that the initial token is DELAY, scanned it 1274 -- out and determined that the current token is not UNTIL 1275 1276 -- Error recovery: cannot raise Error_Resync 1277 1278 function P_Delay_Relative_Statement return Node_Id is 1279 Delay_Node : Node_Id; 1280 1281 begin 1282 Delay_Node := New_Node (N_Delay_Relative_Statement, Prev_Token_Ptr); 1283 Set_Expression (Delay_Node, P_Expression_No_Right_Paren); 1284 Check_Simple_Expression_In_Ada_83 (Expression (Delay_Node)); 1285 TF_Semicolon; 1286 return Delay_Node; 1287 end P_Delay_Relative_Statement; 1288 1289 --------------------------- 1290 -- 9.7 Select Statement -- 1291 --------------------------- 1292 1293 -- SELECT_STATEMENT ::= 1294 -- SELECTIVE_ACCEPT 1295 -- | TIMED_ENTRY_CALL 1296 -- | CONDITIONAL_ENTRY_CALL 1297 -- | ASYNCHRONOUS_SELECT 1298 1299 -- SELECTIVE_ACCEPT ::= 1300 -- select 1301 -- [GUARD] 1302 -- SELECT_ALTERNATIVE 1303 -- {or 1304 -- [GUARD] 1305 -- SELECT_ALTERNATIVE 1306 -- [else 1307 -- SEQUENCE_OF_STATEMENTS] 1308 -- end select; 1309 1310 -- GUARD ::= when CONDITION => 1311 1312 -- Note: the guard preceding a select alternative is included as part 1313 -- of the node generated for a selective accept alternative. 1314 1315 -- SELECT_ALTERNATIVE ::= 1316 -- ACCEPT_ALTERNATIVE 1317 -- | DELAY_ALTERNATIVE 1318 -- | TERMINATE_ALTERNATIVE 1319 1320 -- TIMED_ENTRY_CALL ::= 1321 -- select 1322 -- ENTRY_CALL_ALTERNATIVE 1323 -- or 1324 -- DELAY_ALTERNATIVE 1325 -- end select; 1326 1327 -- CONDITIONAL_ENTRY_CALL ::= 1328 -- select 1329 -- ENTRY_CALL_ALTERNATIVE 1330 -- else 1331 -- SEQUENCE_OF_STATEMENTS 1332 -- end select; 1333 1334 -- ENTRY_CALL_ALTERNATIVE ::= 1335 -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS] 1336 1337 -- ASYNCHRONOUS_SELECT ::= 1338 -- select 1339 -- TRIGGERING_ALTERNATIVE 1340 -- then abort 1341 -- ABORTABLE_PART 1342 -- end select; 1343 1344 -- TRIGGERING_ALTERNATIVE ::= 1345 -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS] 1346 1347 -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT 1348 1349 -- The caller has checked that the initial token is SELECT 1350 1351 -- Error recovery: can raise Error_Resync 1352 1353 function P_Select_Statement return Node_Id is 1354 Select_Node : Node_Id; 1355 Select_Sloc : Source_Ptr; 1356 Stmnt_Sloc : Source_Ptr; 1357 Ecall_Node : Node_Id; 1358 Alternative : Node_Id; 1359 Select_Pragmas : List_Id; 1360 Alt_Pragmas : List_Id; 1361 Statement_List : List_Id; 1362 Alt_List : List_Id; 1363 Cond_Expr : Node_Id; 1364 Delay_Stmnt : Node_Id; 1365 1366 begin 1367 Push_Scope_Stack; 1368 Scope.Table (Scope.Last).Etyp := E_Select; 1369 Scope.Table (Scope.Last).Ecol := Start_Column; 1370 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1371 Scope.Table (Scope.Last).Labl := Error; 1372 1373 Select_Sloc := Token_Ptr; 1374 Scan; -- past SELECT 1375 Stmnt_Sloc := Token_Ptr; 1376 Select_Pragmas := P_Pragmas_Opt; 1377 1378 -- If first token after select is designator, then we have an entry 1379 -- call, which must be the start of a conditional entry call, timed 1380 -- entry call or asynchronous select 1381 1382 if Token in Token_Class_Desig then 1383 1384 -- Scan entry call statement 1385 1386 begin 1387 Ecall_Node := P_Name; 1388 1389 -- ?? The following two clauses exactly parallel code in ch5 1390 -- and should be combined sometime 1391 1392 if Nkind (Ecall_Node) = N_Indexed_Component then 1393 declare 1394 Prefix_Node : constant Node_Id := Prefix (Ecall_Node); 1395 Exprs_Node : constant List_Id := Expressions (Ecall_Node); 1396 1397 begin 1398 Change_Node (Ecall_Node, N_Procedure_Call_Statement); 1399 Set_Name (Ecall_Node, Prefix_Node); 1400 Set_Parameter_Associations (Ecall_Node, Exprs_Node); 1401 end; 1402 1403 elsif Nkind (Ecall_Node) = N_Function_Call then 1404 declare 1405 Fname_Node : constant Node_Id := Name (Ecall_Node); 1406 Params_List : constant List_Id := 1407 Parameter_Associations (Ecall_Node); 1408 1409 begin 1410 Change_Node (Ecall_Node, N_Procedure_Call_Statement); 1411 Set_Name (Ecall_Node, Fname_Node); 1412 Set_Parameter_Associations (Ecall_Node, Params_List); 1413 end; 1414 1415 elsif Nkind (Ecall_Node) = N_Identifier 1416 or else Nkind (Ecall_Node) = N_Selected_Component 1417 then 1418 -- Case of a call to a parameterless entry 1419 1420 declare 1421 C_Node : constant Node_Id := 1422 New_Node (N_Procedure_Call_Statement, Stmnt_Sloc); 1423 begin 1424 Set_Name (C_Node, Ecall_Node); 1425 Set_Parameter_Associations (C_Node, No_List); 1426 Ecall_Node := C_Node; 1427 end; 1428 end if; 1429 1430 TF_Semicolon; 1431 1432 exception 1433 when Error_Resync => 1434 Resync_Past_Semicolon; 1435 return Error; 1436 end; 1437 1438 Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); 1439 1440 -- OR follows, we have a timed entry call 1441 1442 if Token = Tok_Or then 1443 Scan; -- past OR 1444 Alt_Pragmas := P_Pragmas_Opt; 1445 1446 Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc); 1447 Set_Entry_Call_Alternative (Select_Node, 1448 Make_Entry_Call_Alternative (Stmnt_Sloc, 1449 Entry_Call_Statement => Ecall_Node, 1450 Pragmas_Before => Select_Pragmas, 1451 Statements => Statement_List)); 1452 1453 -- Only possibility is delay alternative. If we have anything 1454 -- else, give message, and treat as conditional entry call. 1455 1456 if Token /= Tok_Delay then 1457 Error_Msg_SC 1458 ("only allowed alternative in timed entry call is delay!"); 1459 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); 1460 Set_Delay_Alternative (Select_Node, Error); 1461 1462 else 1463 Set_Delay_Alternative (Select_Node, P_Delay_Alternative); 1464 Set_Pragmas_Before 1465 (Delay_Alternative (Select_Node), Alt_Pragmas); 1466 end if; 1467 1468 -- ELSE follows, we have a conditional entry call 1469 1470 elsif Token = Tok_Else then 1471 Scan; -- past ELSE 1472 Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc); 1473 1474 Set_Entry_Call_Alternative (Select_Node, 1475 Make_Entry_Call_Alternative (Stmnt_Sloc, 1476 Entry_Call_Statement => Ecall_Node, 1477 Pragmas_Before => Select_Pragmas, 1478 Statements => Statement_List)); 1479 1480 Set_Else_Statements 1481 (Select_Node, P_Sequence_Of_Statements (SS_Sreq)); 1482 1483 -- Only remaining case is THEN ABORT (asynchronous select) 1484 1485 elsif Token = Tok_Abort then 1486 Select_Node := 1487 Make_Asynchronous_Select (Select_Sloc, 1488 Triggering_Alternative => 1489 Make_Triggering_Alternative (Stmnt_Sloc, 1490 Triggering_Statement => Ecall_Node, 1491 Pragmas_Before => Select_Pragmas, 1492 Statements => Statement_List), 1493 Abortable_Part => P_Abortable_Part); 1494 1495 -- Else error 1496 1497 else 1498 if Ada_Version = Ada_83 then 1499 Error_Msg_BC ("OR or ELSE expected"); 1500 else 1501 Error_Msg_BC ("OR or ELSE or THEN ABORT expected"); 1502 end if; 1503 1504 Select_Node := Error; 1505 end if; 1506 1507 End_Statements; 1508 1509 -- Here we have a selective accept or an asynchronous select (first 1510 -- token after SELECT is other than a designator token). 1511 1512 else 1513 -- If we have delay with no guard, could be asynchronous select 1514 1515 if Token = Tok_Delay then 1516 Delay_Stmnt := P_Delay_Statement; 1517 Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); 1518 1519 -- Asynchronous select 1520 1521 if Token = Tok_Abort then 1522 Select_Node := 1523 Make_Asynchronous_Select (Select_Sloc, 1524 Triggering_Alternative => 1525 Make_Triggering_Alternative (Stmnt_Sloc, 1526 Triggering_Statement => Delay_Stmnt, 1527 Pragmas_Before => Select_Pragmas, 1528 Statements => Statement_List), 1529 Abortable_Part => P_Abortable_Part); 1530 1531 End_Statements; 1532 return Select_Node; 1533 1534 -- Delay which was not an asynchronous select. Must be a selective 1535 -- accept, and since at least one accept statement is required, 1536 -- we must have at least one OR phrase present. 1537 1538 else 1539 Alt_List := New_List ( 1540 Make_Delay_Alternative (Stmnt_Sloc, 1541 Delay_Statement => Delay_Stmnt, 1542 Pragmas_Before => Select_Pragmas, 1543 Statements => Statement_List)); 1544 T_Or; 1545 Alt_Pragmas := P_Pragmas_Opt; 1546 end if; 1547 1548 -- If not a delay statement, then must be another possibility for 1549 -- a selective accept alternative, or perhaps a guard is present 1550 1551 else 1552 Alt_List := New_List; 1553 Alt_Pragmas := Select_Pragmas; 1554 end if; 1555 1556 Select_Node := New_Node (N_Selective_Accept, Select_Sloc); 1557 Set_Select_Alternatives (Select_Node, Alt_List); 1558 1559 -- Scan out selective accept alternatives. On entry to this loop, 1560 -- we are just past a SELECT or OR token, and any pragmas that 1561 -- immediately follow the SELECT or OR are in Alt_Pragmas. 1562 1563 loop 1564 if Token = Tok_When then 1565 1566 if Present (Alt_Pragmas) then 1567 Error_Msg_SC ("pragmas may not precede guard"); 1568 end if; 1569 1570 Scan; -- past WHEN 1571 Cond_Expr := P_Expression_No_Right_Paren; 1572 T_Arrow; 1573 Alt_Pragmas := P_Pragmas_Opt; 1574 1575 else 1576 Cond_Expr := Empty; 1577 end if; 1578 1579 if Token = Tok_Accept then 1580 Alternative := P_Accept_Alternative; 1581 1582 -- Check for junk attempt at asynchronous select using 1583 -- an Accept alternative as the triggering statement 1584 1585 if Token = Tok_Abort 1586 and then Is_Empty_List (Alt_List) 1587 and then No (Cond_Expr) 1588 then 1589 Error_Msg 1590 ("triggering statement must be entry call or delay", 1591 Sloc (Alternative)); 1592 Scan; -- past junk ABORT 1593 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); 1594 End_Statements; 1595 return Error; 1596 end if; 1597 1598 elsif Token = Tok_Delay then 1599 Alternative := P_Delay_Alternative; 1600 1601 elsif Token = Tok_Terminate then 1602 Alternative := P_Terminate_Alternative; 1603 1604 else 1605 Error_Msg_SC 1606 ("select alternative (ACCEPT, ABORT, DELAY) expected"); 1607 Alternative := Error; 1608 1609 if Token = Tok_Semicolon then 1610 Scan; -- past junk semicolon 1611 end if; 1612 end if; 1613 1614 -- THEN ABORT at this stage is just junk 1615 1616 if Token = Tok_Abort then 1617 Error_Msg_SP ("misplaced `THEN ABORT`"); 1618 Scan; -- past junk ABORT 1619 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); 1620 End_Statements; 1621 return Error; 1622 1623 else 1624 if Alternative /= Error then 1625 Set_Condition (Alternative, Cond_Expr); 1626 Set_Pragmas_Before (Alternative, Alt_Pragmas); 1627 Append (Alternative, Alt_List); 1628 end if; 1629 1630 exit when Token /= Tok_Or; 1631 end if; 1632 1633 T_Or; 1634 Alt_Pragmas := P_Pragmas_Opt; 1635 end loop; 1636 1637 if Token = Tok_Else then 1638 Scan; -- past ELSE 1639 Set_Else_Statements 1640 (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq)); 1641 1642 if Token = Tok_Or then 1643 Error_Msg_SC ("select alternative cannot follow else part!"); 1644 end if; 1645 end if; 1646 1647 End_Statements; 1648 end if; 1649 1650 return Select_Node; 1651 end P_Select_Statement; 1652 1653 ----------------------------- 1654 -- 9.7.1 Selective Accept -- 1655 ----------------------------- 1656 1657 -- Parsed by P_Select_Statement (9.7) 1658 1659 ------------------ 1660 -- 9.7.1 Guard -- 1661 ------------------ 1662 1663 -- Parsed by P_Select_Statement (9.7) 1664 1665 ------------------------------- 1666 -- 9.7.1 Select Alternative -- 1667 ------------------------------- 1668 1669 -- SELECT_ALTERNATIVE ::= 1670 -- ACCEPT_ALTERNATIVE 1671 -- | DELAY_ALTERNATIVE 1672 -- | TERMINATE_ALTERNATIVE 1673 1674 -- Note: the guard preceding a select alternative is included as part 1675 -- of the node generated for a selective accept alternative. 1676 1677 -- Error recovery: cannot raise Error_Resync 1678 1679 ------------------------------- 1680 -- 9.7.1 Accept Alternative -- 1681 ------------------------------- 1682 1683 -- ACCEPT_ALTERNATIVE ::= 1684 -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS] 1685 1686 -- Error_Recovery: Cannot raise Error_Resync 1687 1688 -- Note: the caller is responsible for setting the Pragmas_Before 1689 -- field of the returned N_Terminate_Alternative node. 1690 1691 function P_Accept_Alternative return Node_Id is 1692 Accept_Alt_Node : Node_Id; 1693 1694 begin 1695 Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr); 1696 Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement); 1697 1698 -- Note: the reason that we accept THEN ABORT as a terminator for 1699 -- the sequence of statements is for error recovery which allows 1700 -- for misuse of an accept statement as a triggering statement. 1701 1702 Set_Statements 1703 (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); 1704 return Accept_Alt_Node; 1705 end P_Accept_Alternative; 1706 1707 ------------------------------ 1708 -- 9.7.1 Delay Alternative -- 1709 ------------------------------ 1710 1711 -- DELAY_ALTERNATIVE ::= 1712 -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS] 1713 1714 -- Error_Recovery: Cannot raise Error_Resync 1715 1716 -- Note: the caller is responsible for setting the Pragmas_Before 1717 -- field of the returned N_Terminate_Alternative node. 1718 1719 function P_Delay_Alternative return Node_Id is 1720 Delay_Alt_Node : Node_Id; 1721 1722 begin 1723 Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr); 1724 Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement); 1725 1726 -- Note: the reason that we accept THEN ABORT as a terminator for 1727 -- the sequence of statements is for error recovery which allows 1728 -- for misuse of an accept statement as a triggering statement. 1729 1730 Set_Statements 1731 (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); 1732 return Delay_Alt_Node; 1733 end P_Delay_Alternative; 1734 1735 ---------------------------------- 1736 -- 9.7.1 Terminate Alternative -- 1737 ---------------------------------- 1738 1739 -- TERMINATE_ALTERNATIVE ::= terminate; 1740 1741 -- Error_Recovery: Cannot raise Error_Resync 1742 1743 -- Note: the caller is responsible for setting the Pragmas_Before 1744 -- field of the returned N_Terminate_Alternative node. 1745 1746 function P_Terminate_Alternative return Node_Id is 1747 Terminate_Alt_Node : Node_Id; 1748 1749 begin 1750 Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr); 1751 Scan; -- past TERMINATE 1752 TF_Semicolon; 1753 1754 -- For all other select alternatives, the sequence of statements 1755 -- after the alternative statement will swallow up any pragmas 1756 -- coming in this position. But the terminate alternative has no 1757 -- sequence of statements, so the pragmas here must be treated 1758 -- specially. 1759 1760 Set_Pragmas_After (Terminate_Alt_Node, P_Pragmas_Opt); 1761 return Terminate_Alt_Node; 1762 end P_Terminate_Alternative; 1763 1764 ----------------------------- 1765 -- 9.7.2 Timed Entry Call -- 1766 ----------------------------- 1767 1768 -- Parsed by P_Select_Statement (9.7) 1769 1770 ----------------------------------- 1771 -- 9.7.2 Entry Call Alternative -- 1772 ----------------------------------- 1773 1774 -- Parsed by P_Select_Statement (9.7) 1775 1776 ----------------------------------- 1777 -- 9.7.3 Conditional Entry Call -- 1778 ----------------------------------- 1779 1780 -- Parsed by P_Select_Statement (9.7) 1781 1782 -------------------------------- 1783 -- 9.7.4 Asynchronous Select -- 1784 -------------------------------- 1785 1786 -- Parsed by P_Select_Statement (9.7) 1787 1788 ----------------------------------- 1789 -- 9.7.4 Triggering Alternative -- 1790 ----------------------------------- 1791 1792 -- Parsed by P_Select_Statement (9.7) 1793 1794 --------------------------------- 1795 -- 9.7.4 Triggering Statement -- 1796 --------------------------------- 1797 1798 -- Parsed by P_Select_Statement (9.7) 1799 1800 --------------------------- 1801 -- 9.7.4 Abortable Part -- 1802 --------------------------- 1803 1804 -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS 1805 1806 -- The caller has verified that THEN ABORT is present, and Token is 1807 -- pointing to the ABORT on entry (or if not, then we have an error) 1808 1809 -- Error recovery: cannot raise Error_Resync 1810 1811 function P_Abortable_Part return Node_Id is 1812 Abortable_Part_Node : Node_Id; 1813 1814 begin 1815 Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr); 1816 T_Abort; -- scan past ABORT 1817 1818 if Ada_Version = Ada_83 then 1819 Error_Msg_SP ("(Ada 83) asynchronous select not allowed!"); 1820 end if; 1821 1822 Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq)); 1823 return Abortable_Part_Node; 1824 end P_Abortable_Part; 1825 1826 -------------------------- 1827 -- 9.8 Abort Statement -- 1828 -------------------------- 1829 1830 -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME}; 1831 1832 -- The caller has checked that the initial token is ABORT 1833 1834 -- Error recovery: cannot raise Error_Resync 1835 1836 function P_Abort_Statement return Node_Id is 1837 Abort_Node : Node_Id; 1838 1839 begin 1840 Abort_Node := New_Node (N_Abort_Statement, Token_Ptr); 1841 Scan; -- past ABORT 1842 Set_Names (Abort_Node, New_List); 1843 1844 loop 1845 Append (P_Name, Names (Abort_Node)); 1846 exit when Token /= Tok_Comma; 1847 Scan; -- past comma 1848 end loop; 1849 1850 TF_Semicolon; 1851 return Abort_Node; 1852 end P_Abort_Statement; 1853 1854end Ch9; 1855