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