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
26pragma Style_Checks (All_Checks);
27--  Turn off subprogram body ordering check. Subprograms are in order by RM
28--  section rather than alphabetical.
29
30separate (Par)
31package 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
2010end Ch9;
2011