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