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