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