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