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