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