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