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