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