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