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