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