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