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