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