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