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 --          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
  27 pragma Style_Checks (All_Checks);
  28 --  Turn off subprogram body ordering check. Subprograms are in order
  29 --  by RM section rather than alphabetical
  30
  31 separate (Par)
  32 package 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
1617 end Ch9;