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