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