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