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