gcc/ada/par-ch9.adb

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