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