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