?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
FSF GCC merge 02/23/03
[official-gcc.git] / gcc / ada / par-ch9.adb
blobb9afa949586561d4c2b6ad9dc0e4d5c4f9d74bc7
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P A R . C H 9 --
6 -- --
7 -- B o d y --
8 -- --
9 -- --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 -- --
26 ------------------------------------------------------------------------------
27
28 pragma Style_Checks (All_Checks);
29 -- Turn off subprogram body ordering check. Subprograms are in order
30 -- by RM section rather than alphabetical
31
32 separate (Par)
33 package body Ch9 is
34
35 -- Local subprograms, used only in this chapter
36
37 function P_Accept_Alternative return Node_Id;
38 function P_Delay_Alternative return Node_Id;
39 function P_Delay_Relative_Statement return Node_Id;
40 function P_Delay_Until_Statement return Node_Id;
41 function P_Entry_Barrier return Node_Id;
42 function P_Entry_Body_Formal_Part return Node_Id;
43 function P_Entry_Declaration return Node_Id;
44 function P_Entry_Index_Specification return Node_Id;
45 function P_Protected_Definition return Node_Id;
46 function P_Protected_Operation_Declaration_Opt return Node_Id;
47 function P_Protected_Operation_Items return List_Id;
48 function P_Task_Definition return Node_Id;
49 function P_Task_Items return List_Id;
50
51 -----------------------------
52 -- 9.1 Task (also 10.1.3) --
53 -----------------------------
54
55 -- TASK_TYPE_DECLARATION ::=
56 -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
57 -- [is TASK_DEFINITION];
58
59 -- SINGLE_TASK_DECLARATION ::=
60 -- task DEFINING_IDENTIFIER [is TASK_DEFINITION];
61
62 -- TASK_BODY ::=
63 -- task body DEFINING_IDENTIFIER is
64 -- DECLARATIVE_PART
65 -- begin
66 -- HANDLED_SEQUENCE_OF_STATEMENTS
67 -- end [task_IDENTIFIER]
68
69 -- TASK_BODY_STUB ::=
70 -- task body DEFINING_IDENTIFIER is separate;
71
72 -- This routine scans out a task declaration, task body, or task stub
73
74 -- The caller has checked that the initial token is TASK and scanned
75 -- past it, so that Token is set to the token after TASK
76
77 -- Error recovery: cannot raise Error_Resync
78
79 function P_Task return Node_Id is
80 Name_Node : Node_Id;
81 Task_Node : Node_Id;
82 Task_Sloc : Source_Ptr;
83
84 begin
85 Push_Scope_Stack;
86 Scope.Table (Scope.Last).Etyp := E_Name;
87 Scope.Table (Scope.Last).Ecol := Start_Column;
88 Scope.Table (Scope.Last).Sloc := Token_Ptr;
89 Scope.Table (Scope.Last).Lreq := False;
90 Task_Sloc := Prev_Token_Ptr;
91
92 if Token = Tok_Body then
93 Scan; -- past BODY
94 Name_Node := P_Defining_Identifier;
95 Scope.Table (Scope.Last).Labl := Name_Node;
96
97 if Token = Tok_Left_Paren then
98 Error_Msg_SC ("discriminant part not allowed in task body");
99 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
100 end if;
101
102 TF_Is;
103
104 -- Task stub
105
106 if Token = Tok_Separate then
107 Scan; -- past SEPARATE
108 Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc);
109 Set_Defining_Identifier (Task_Node, Name_Node);
110 TF_Semicolon;
111 Pop_Scope_Stack; -- remove unused entry
112
113 -- Task body
114
115 else
116 Task_Node := New_Node (N_Task_Body, Task_Sloc);
117 Set_Defining_Identifier (Task_Node, Name_Node);
118 Parse_Decls_Begin_End (Task_Node);
119 end if;
120
121 return Task_Node;
122
123 -- Otherwise we must have a task declaration
124
125 else
126 if Token = Tok_Type then
127 Scan; -- past TYPE
128 Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc);
129 Name_Node := P_Defining_Identifier;
130 Set_Defining_Identifier (Task_Node, Name_Node);
131 Scope.Table (Scope.Last).Labl := Name_Node;
132 Set_Discriminant_Specifications
133 (Task_Node, P_Known_Discriminant_Part_Opt);
134
135 else
136 Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc);
137 Name_Node := P_Defining_Identifier;
138 Set_Defining_Identifier (Task_Node, Name_Node);
139 Scope.Table (Scope.Last).Labl := Name_Node;
140
141 if Token = Tok_Left_Paren then
142 Error_Msg_SC ("discriminant part not allowed for single task");
143 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
144 end if;
145
146 end if;
147
148 -- Parse optional task definition. Note that P_Task_Definition scans
149 -- out the semicolon as well as the task definition itself.
150
151 if Token = Tok_Semicolon then
152
153 -- A little check, if the next token after semicolon is
154 -- Entry, then surely the semicolon should really be IS
155
156 Scan; -- past semicolon
157
158 if Token = Tok_Entry then
159 Error_Msg_SP (""";"" should be IS");
160 Set_Task_Definition (Task_Node, P_Task_Definition);
161 else
162 Pop_Scope_Stack; -- Remove unused entry
163 end if;
164 else
165 TF_Is; -- must have IS if no semicolon
166 Set_Task_Definition (Task_Node, P_Task_Definition);
167 end if;
168
169 return Task_Node;
170 end if;
171 end P_Task;
172
173 --------------------------------
174 -- 9.1 Task Type Declaration --
175 --------------------------------
176
177 -- Parsed by P_Task (9.1)
178
179 ----------------------------------
180 -- 9.1 Single Task Declaration --
181 ----------------------------------
182
183 -- Parsed by P_Task (9.1)
184
185 --------------------------
186 -- 9.1 Task Definition --
187 --------------------------
188
189 -- TASK_DEFINITION ::=
190 -- {TASK_ITEM}
191 -- [private
192 -- {TASK_ITEM}]
193 -- end [task_IDENTIFIER];
194
195 -- The caller has already made the scope stack entry
196
197 -- Note: there is a small deviation from official syntax here in that we
198 -- regard the semicolon after end as part of the Task_Definition, and in
199 -- the official syntax, it's part of the enclosing declaration. The reason
200 -- for this deviation is that otherwise the end processing would have to
201 -- be special cased, which would be a nuisance!
202
203 -- Error recovery: cannot raise Error_Resync
204
205 function P_Task_Definition return Node_Id is
206 Def_Node : Node_Id;
207
208 begin
209 Def_Node := New_Node (N_Task_Definition, Token_Ptr);
210 Set_Visible_Declarations (Def_Node, P_Task_Items);
211
212 if Token = Tok_Private then
213 Scan; -- past PRIVATE
214 Set_Private_Declarations (Def_Node, P_Task_Items);
215
216 -- Deal gracefully with multiple PRIVATE parts
217
218 while Token = Tok_Private loop
219 Error_Msg_SC ("Only one private part allowed per task");
220 Scan; -- past PRIVATE
221 Append_List (P_Task_Items, Private_Declarations (Def_Node));
222 end loop;
223 end if;
224
225 End_Statements (Def_Node);
226 return Def_Node;
227 end P_Task_Definition;
228
229 --------------------
230 -- 9.1 Task Item --
231 --------------------
232
233 -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE
234
235 -- This subprogram scans a (possibly empty) list of task items and pragmas
236
237 -- Error recovery: cannot raise Error_Resync
238
239 -- Note: a pragma can also be returned in this position
240
241 function P_Task_Items return List_Id is
242 Items : List_Id;
243 Item_Node : Node_Id;
244 Decl_Sloc : Source_Ptr;
245
246 begin
247 -- Get rid of active SIS entry from outer scope. This means we will
248 -- miss some nested cases, but it doesn't seem worth the effort. See
249 -- discussion in Par for further details
250
251 SIS_Entry_Active := False;
252
253 -- Loop to scan out task items
254
255 Items := New_List;
256
257 Decl_Loop : loop
258 Decl_Sloc := Token_Ptr;
259
260 if Token = Tok_Pragma then
261 Append (P_Pragma, Items);
262
263 elsif Token = Tok_Entry then
264 Append (P_Entry_Declaration, Items);
265
266 elsif Token = Tok_For then
267 -- Representation clause in task declaration. The only rep
268 -- clause which is legal in a protected is an address clause,
269 -- so that is what we try to scan out.
270
271 Item_Node := P_Representation_Clause;
272
273 if Nkind (Item_Node) = N_At_Clause then
274 Append (Item_Node, Items);
275
276 elsif Nkind (Item_Node) = N_Attribute_Definition_Clause
277 and then Chars (Item_Node) = Name_Address
278 then
279 Append (Item_Node, Items);
280
281 else
282 Error_Msg
283 ("the only representation clause " &
284 "allowed here is an address clause!", Decl_Sloc);
285 end if;
286
287 elsif Token = Tok_Identifier
288 or else Token in Token_Class_Declk
289 then
290 Error_Msg_SC ("Illegal declaration in task definition");
291 Resync_Past_Semicolon;
292
293 else
294 exit Decl_Loop;
295 end if;
296 end loop Decl_Loop;
297
298 return Items;
299 end P_Task_Items;
300
301 --------------------
302 -- 9.1 Task Body --
303 --------------------
304
305 -- Parsed by P_Task (9.1)
306
307 ----------------------------------
308 -- 9.4 Protected (also 10.1.3) --
309 ----------------------------------
310
311 -- PROTECTED_TYPE_DECLARATION ::=
312 -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
313 -- is PROTECTED_DEFINITION;
314
315 -- SINGLE_PROTECTED_DECLARATION ::=
316 -- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION;
317
318 -- PROTECTED_BODY ::=
319 -- protected body DEFINING_IDENTIFIER is
320 -- {PROTECTED_OPERATION_ITEM}
321 -- end [protected_IDENTIFIER];
322
323 -- PROTECTED_BODY_STUB ::=
324 -- protected body DEFINING_IDENTIFIER is separate;
325
326 -- This routine scans out a protected declaration, protected body
327 -- or a protected stub.
328
329 -- The caller has checked that the initial token is PROTECTED and
330 -- scanned past it, so Token is set to the following token.
331
332 -- Error recovery: cannot raise Error_Resync
333
334 function P_Protected return Node_Id is
335 Name_Node : Node_Id;
336 Protected_Node : Node_Id;
337 Protected_Sloc : Source_Ptr;
338
339 begin
340 Push_Scope_Stack;
341 Scope.Table (Scope.Last).Etyp := E_Name;
342 Scope.Table (Scope.Last).Ecol := Start_Column;
343 Scope.Table (Scope.Last).Lreq := False;
344 Protected_Sloc := Prev_Token_Ptr;
345
346 if Token = Tok_Body then
347 Scan; -- past BODY
348 Name_Node := P_Defining_Identifier;
349 Scope.Table (Scope.Last).Labl := Name_Node;
350
351 if Token = Tok_Left_Paren then
352 Error_Msg_SC ("discriminant part not allowed in protected body");
353 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
354 end if;
355
356 TF_Is;
357
358 -- Protected stub
359
360 if Token = Tok_Separate then
361 Scan; -- past SEPARATE
362 Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc);
363 Set_Defining_Identifier (Protected_Node, Name_Node);
364 TF_Semicolon;
365 Pop_Scope_Stack; -- remove unused entry
366
367 -- Protected body
368
369 else
370 Protected_Node := New_Node (N_Protected_Body, Protected_Sloc);
371 Set_Defining_Identifier (Protected_Node, Name_Node);
372 Set_Declarations (Protected_Node, P_Protected_Operation_Items);
373 End_Statements (Protected_Node);
374 end if;
375
376 return Protected_Node;
377
378 -- Otherwise we must have a protected declaration
379
380 else
381 if Token = Tok_Type then
382 Scan; -- past TYPE
383 Protected_Node :=
384 New_Node (N_Protected_Type_Declaration, Protected_Sloc);
385 Name_Node := P_Defining_Identifier;
386 Set_Defining_Identifier (Protected_Node, Name_Node);
387 Scope.Table (Scope.Last).Labl := Name_Node;
388 Set_Discriminant_Specifications
389 (Protected_Node, P_Known_Discriminant_Part_Opt);
390
391 else
392 Protected_Node :=
393 New_Node (N_Single_Protected_Declaration, Protected_Sloc);
394 Name_Node := P_Defining_Identifier;
395 Set_Defining_Identifier (Protected_Node, Name_Node);
396
397 if Token = Tok_Left_Paren then
398 Error_Msg_SC
399 ("discriminant part not allowed for single protected");
400 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
401 end if;
402
403 Scope.Table (Scope.Last).Labl := Name_Node;
404 end if;
405
406 T_Is;
407 Set_Protected_Definition (Protected_Node, P_Protected_Definition);
408 return Protected_Node;
409 end if;
410 end P_Protected;
411
412 -------------------------------------
413 -- 9.4 Protected Type Declaration --
414 -------------------------------------
415
416 -- Parsed by P_Protected (9.4)
417
418 ---------------------------------------
419 -- 9.4 Single Protected Declaration --
420 ---------------------------------------
421
422 -- Parsed by P_Protected (9.4)
423
424 -------------------------------
425 -- 9.4 Protected Definition --
426 -------------------------------
427
428 -- PROTECTED_DEFINITION ::=
429 -- {PROTECTED_OPERATION_DECLARATION}
430 -- [private
431 -- {PROTECTED_ELEMENT_DECLARATION}]
432 -- end [protected_IDENTIFIER]
433
434 -- PROTECTED_ELEMENT_DECLARATION ::=
435 -- PROTECTED_OPERATION_DECLARATION
436 -- | COMPONENT_DECLARATION
437
438 -- The caller has already established the scope stack entry
439
440 -- Error recovery: cannot raise Error_Resync
441
442 function P_Protected_Definition return Node_Id is
443 Def_Node : Node_Id;
444 Item_Node : Node_Id;
445
446 begin
447 Def_Node := New_Node (N_Protected_Definition, Token_Ptr);
448
449 -- Get rid of active SIS entry from outer scope. This means we will
450 -- miss some nested cases, but it doesn't seem worth the effort. See
451 -- discussion in Par for further details
452
453 SIS_Entry_Active := False;
454
455 -- Loop to scan visible declarations (protected operation declarations)
456
457 Set_Visible_Declarations (Def_Node, New_List);
458
459 loop
460 Item_Node := P_Protected_Operation_Declaration_Opt;
461 exit when No (Item_Node);
462 Append (Item_Node, Visible_Declarations (Def_Node));
463 end loop;
464
465 -- Deal with PRIVATE part (including graceful handling
466 -- of multiple PRIVATE parts).
467
468 Private_Loop : while Token = Tok_Private loop
469 if No (Private_Declarations (Def_Node)) then
470 Set_Private_Declarations (Def_Node, New_List);
471 else
472 Error_Msg_SC ("duplicate private part");
473 end if;
474
475 Scan; -- past PRIVATE
476
477 Declaration_Loop : loop
478 if Token = Tok_Identifier then
479 P_Component_Items (Private_Declarations (Def_Node));
480 else
481 Item_Node := P_Protected_Operation_Declaration_Opt;
482 exit Declaration_Loop when No (Item_Node);
483 Append (Item_Node, Private_Declarations (Def_Node));
484 end if;
485 end loop Declaration_Loop;
486 end loop Private_Loop;
487
488 End_Statements (Def_Node);
489 return Def_Node;
490 end P_Protected_Definition;
491
492 ------------------------------------------
493 -- 9.4 Protected Operation Declaration --
494 ------------------------------------------
495
496 -- PROTECTED_OPERATION_DECLARATION ::=
497 -- SUBPROGRAM_DECLARATION
498 -- | ENTRY_DECLARATION
499 -- | REPRESENTATION_CLAUSE
500
501 -- Error recovery: cannot raise Error_Resync
502
503 -- Note: a pragma can also be returned in this position
504
505 -- We are not currently permitting representation clauses to appear as
506 -- protected operation declarations, do we have to rethink this???
507
508 function P_Protected_Operation_Declaration_Opt return Node_Id is
509 L : List_Id;
510 P : Source_Ptr;
511
512 begin
513 -- This loop runs more than once only when a junk declaration
514 -- is skipped.
515
516 loop
517 if Token = Tok_Pragma then
518 return P_Pragma;
519
520 elsif Token = Tok_Entry then
521 return P_Entry_Declaration;
522
523 elsif Token = Tok_Function or else Token = Tok_Procedure then
524 return P_Subprogram (Pf_Decl);
525
526 elsif Token = Tok_Identifier then
527 L := New_List;
528 P := Token_Ptr;
529 Skip_Declaration (L);
530
531 if Nkind (First (L)) = N_Object_Declaration then
532 Error_Msg
533 ("component must be declared in private part of " &
534 "protected type", P);
535 else
536 Error_Msg
537 ("illegal declaration in protected definition", P);
538 end if;
539
540 elsif Token in Token_Class_Declk then
541 Error_Msg_SC ("illegal declaration in protected definition");
542 Resync_Past_Semicolon;
543
544 -- Return now to avoid cascaded messages if next declaration
545 -- is a valid component declaration.
546
547 return Error;
548
549 elsif Token = Tok_For then
550 Error_Msg_SC
551 ("representation clause not allowed in protected definition");
552 Resync_Past_Semicolon;
553
554 else
555 return Empty;
556 end if;
557 end loop;
558 end P_Protected_Operation_Declaration_Opt;
559
560 -----------------------------------
561 -- 9.4 Protected Operation Item --
562 -----------------------------------
563
564 -- PROTECTED_OPERATION_ITEM ::=
565 -- SUBPROGRAM_DECLARATION
566 -- | SUBPROGRAM_BODY
567 -- | ENTRY_BODY
568 -- | REPRESENTATION_CLAUSE
569
570 -- This procedure parses and returns a list of protected operation items
571
572 -- We are not currently permitting representation clauses to appear
573 -- as protected operation items, do we have to rethink this???
574
575 function P_Protected_Operation_Items return List_Id is
576 Item_List : List_Id;
577
578 begin
579 Item_List := New_List;
580
581 loop
582 if Token = Tok_Entry or else Bad_Spelling_Of (Tok_Entry) then
583 Append (P_Entry_Body, Item_List);
584
585 elsif Token = Tok_Function or else Bad_Spelling_Of (Tok_Function)
586 or else
587 Token = Tok_Procedure or else Bad_Spelling_Of (Tok_Procedure)
588 then
589 Append (P_Subprogram (Pf_Decl_Pbod), Item_List);
590
591 elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then
592 P_Pragmas_Opt (Item_List);
593
594 elsif Token = Tok_Private or else Bad_Spelling_Of (Tok_Private) then
595 Error_Msg_SC ("PRIVATE not allowed in protected body");
596 Scan; -- past PRIVATE
597
598 elsif Token = Tok_Identifier then
599 Error_Msg_SC
600 ("all components must be declared in spec!");
601 Resync_Past_Semicolon;
602
603 elsif Token in Token_Class_Declk then
604 Error_Msg_SC ("this declaration not allowed in protected body");
605 Resync_Past_Semicolon;
606
607 else
608 exit;
609 end if;
610 end loop;
611
612 return Item_List;
613 end P_Protected_Operation_Items;
614
615 ------------------------------
616 -- 9.5.2 Entry Declaration --
617 ------------------------------
618
619 -- ENTRY_DECLARATION ::=
620 -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)]
621 -- PARAMETER_PROFILE;
622
623 -- The caller has checked that the initial token is ENTRY
624
625 -- Error recovery: cannot raise Error_Resync
626
627 function P_Entry_Declaration return Node_Id is
628 Decl_Node : Node_Id;
629 Scan_State : Saved_Scan_State;
630
631 begin
632 Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
633 Scan; -- past ENTRY
634
635 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
636
637 -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
638
639 if Token = Tok_Left_Paren then
640 Scan; -- past (
641
642 -- If identifier after left paren, could still be either
643
644 if Token = Tok_Identifier then
645 Save_Scan_State (Scan_State); -- at Id
646 Scan; -- past Id
647
648 -- If comma or colon after Id, must be Formal_Part
649
650 if Token = Tok_Comma or else Token = Tok_Colon then
651 Restore_Scan_State (Scan_State); -- to Id
652 Set_Parameter_Specifications (Decl_Node, P_Formal_Part);
653
654 -- Else if Id wi no comma or colon, must be discrete subtype defn
655
656 else
657 Restore_Scan_State (Scan_State); -- to Id
658 Set_Discrete_Subtype_Definition
659 (Decl_Node, P_Discrete_Subtype_Definition);
660 T_Right_Paren;
661 Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
662 end if;
663
664 -- If no Id, must be discrete subtype definition
665
666 else
667 Set_Discrete_Subtype_Definition
668 (Decl_Node, P_Discrete_Subtype_Definition);
669 T_Right_Paren;
670 Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
671 end if;
672 end if;
673
674 -- Error recovery check for illegal return
675
676 if Token = Tok_Return then
677 Error_Msg_SC ("entry cannot have return value!");
678 Scan;
679 Discard_Junk_Node (P_Subtype_Indication);
680 end if;
681
682 -- Error recovery check for improper use of entry barrier in spec
683
684 if Token = Tok_When then
685 Error_Msg_SC ("barrier not allowed here (belongs in body)");
686 Scan; -- past WHEN;
687 Discard_Junk_Node (P_Expression_No_Right_Paren);
688 end if;
689
690 TF_Semicolon;
691 return Decl_Node;
692 end P_Entry_Declaration;
693
694 -----------------------------
695 -- 9.5.2 Accept Statement --
696 -----------------------------
697
698 -- ACCEPT_STATEMENT ::=
699 -- accept entry_DIRECT_NAME
700 -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do
701 -- HANDLED_SEQUENCE_OF_STATEMENTS
702 -- end [entry_IDENTIFIER]];
703
704 -- The caller has checked that the initial token is ACCEPT
705
706 -- Error recovery: cannot raise Error_Resync. If an error occurs, the
707 -- scan is resynchronized past the next semicolon and control returns.
708
709 function P_Accept_Statement return Node_Id is
710 Scan_State : Saved_Scan_State;
711 Accept_Node : Node_Id;
712 Hand_Seq : Node_Id;
713
714 begin
715 Push_Scope_Stack;
716 Scope.Table (Scope.Last).Sloc := Token_Ptr;
717 Scope.Table (Scope.Last).Ecol := Start_Column;
718
719 Accept_Node := New_Node (N_Accept_Statement, Token_Ptr);
720 Scan; -- past ACCEPT
721 Scope.Table (Scope.Last).Labl := Token_Node;
722
723 Set_Entry_Direct_Name (Accept_Node, P_Identifier);
724
725 -- Left paren could be (Entry_Index) or Formal_Part, determine which
726
727 if Token = Tok_Left_Paren then
728 Save_Scan_State (Scan_State); -- at left paren
729 Scan; -- past left paren
730
731 -- If first token after left paren not identifier, then Entry_Index
732
733 if Token /= Tok_Identifier then
734 Set_Entry_Index (Accept_Node, P_Expression);
735 T_Right_Paren;
736 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
737
738 -- First token after left paren is identifier, could be either case
739
740 else -- Token = Tok_Identifier
741 Scan; -- past identifier
742
743 -- If identifier followed by comma or colon, must be Formal_Part
744
745 if Token = Tok_Comma or else Token = Tok_Colon then
746 Restore_Scan_State (Scan_State); -- to left paren
747 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
748
749 -- If identifier not followed by comma/colon, must be entry index
750
751 else
752 Restore_Scan_State (Scan_State); -- to left paren
753 Scan; -- past left paren (again!)
754 Set_Entry_Index (Accept_Node, P_Expression);
755 T_Right_Paren;
756 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
757 end if;
758 end if;
759 end if;
760
761 -- Scan out DO if present
762
763 if Token = Tok_Do then
764 Scope.Table (Scope.Last).Etyp := E_Name;
765 Scope.Table (Scope.Last).Lreq := False;
766 Scan; -- past DO
767 Hand_Seq := P_Handled_Sequence_Of_Statements;
768 Set_Handled_Statement_Sequence (Accept_Node, Hand_Seq);
769 End_Statements (Handled_Statement_Sequence (Accept_Node));
770
771 -- Exception handlers not allowed in Ada 95 node
772
773 if Present (Exception_Handlers (Hand_Seq)) then
774 if Ada_83 then
775 Error_Msg_N
776 ("(Ada 83) exception handlers in accept not allowed",
777 First_Non_Pragma (Exception_Handlers (Hand_Seq)));
778 end if;
779 end if;
780
781 else
782 Pop_Scope_Stack; -- discard unused entry
783 TF_Semicolon;
784 end if;
785
786 return Accept_Node;
787
788 -- If error, resynchronize past semicolon
789
790 exception
791 when Error_Resync =>
792 Resync_Past_Semicolon;
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);
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 : Node_Id := Prefix (Ecall_Node);
1158 Exprs_Node : List_Id := Expressions (Ecall_Node);
1159 begin
1160 Change_Node (Ecall_Node, N_Procedure_Call_Statement);
1161 Set_Name (Ecall_Node, Prefix_Node);
1162 Set_Parameter_Associations (Ecall_Node, Exprs_Node);
1163 end;
1164
1165 elsif Nkind (Ecall_Node) = N_Function_Call then
1166 declare
1167 Fname_Node : Node_Id := Name (Ecall_Node);
1168 Params_List : List_Id := Parameter_Associations (Ecall_Node);
1169
1170 begin
1171 Change_Node (Ecall_Node, N_Procedure_Call_Statement);
1172 Set_Name (Ecall_Node, Fname_Node);
1173 Set_Parameter_Associations (Ecall_Node, Params_List);
1174 end;
1175
1176 elsif Nkind (Ecall_Node) = N_Identifier
1177 or else Nkind (Ecall_Node) = N_Selected_Component
1178 then
1179 -- Case of a call to a parameterless entry.
1180
1181 declare
1182 C_Node : constant Node_Id :=
1183 New_Node (N_Procedure_Call_Statement, Stmnt_Sloc);
1184 begin
1185 Set_Name (C_Node, Ecall_Node);
1186 Set_Parameter_Associations (C_Node, No_List);
1187 Ecall_Node := C_Node;
1188 end;
1189 end if;
1190
1191 TF_Semicolon;
1192
1193 exception
1194 when Error_Resync =>
1195 Resync_Past_Semicolon;
1196 return Error;
1197 end;
1198
1199 Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
1200
1201 -- OR follows, we have a timed entry call
1202
1203 if Token = Tok_Or then
1204 Scan; -- past OR
1205 Alt_Pragmas := P_Pragmas_Opt;
1206
1207 Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc);
1208 Set_Entry_Call_Alternative (Select_Node,
1209 Make_Entry_Call_Alternative (Stmnt_Sloc,
1210 Entry_Call_Statement => Ecall_Node,
1211 Pragmas_Before => Select_Pragmas,
1212 Statements => Statement_List));
1213
1214 -- Only possibility is delay alternative. If we have anything
1215 -- else, give message, and treat as conditional entry call.
1216
1217 if Token /= Tok_Delay then
1218 Error_Msg_SC
1219 ("only allowed alternative in timed entry call is delay!");
1220 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1221 Set_Delay_Alternative (Select_Node, Error);
1222
1223 else
1224 Set_Delay_Alternative (Select_Node, P_Delay_Alternative);
1225 Set_Pragmas_Before
1226 (Delay_Alternative (Select_Node), Alt_Pragmas);
1227 end if;
1228
1229 -- ELSE follows, we have a conditional entry call
1230
1231 elsif Token = Tok_Else then
1232 Scan; -- past ELSE
1233 Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc);
1234
1235 Set_Entry_Call_Alternative (Select_Node,
1236 Make_Entry_Call_Alternative (Stmnt_Sloc,
1237 Entry_Call_Statement => Ecall_Node,
1238 Pragmas_Before => Select_Pragmas,
1239 Statements => Statement_List));
1240
1241 Set_Else_Statements
1242 (Select_Node, P_Sequence_Of_Statements (SS_Sreq));
1243
1244 -- Only remaining case is THEN ABORT (asynchronous select)
1245
1246 elsif Token = Tok_Abort then
1247 Select_Node :=
1248 Make_Asynchronous_Select (Select_Sloc,
1249 Triggering_Alternative =>
1250 Make_Triggering_Alternative (Stmnt_Sloc,
1251 Triggering_Statement => Ecall_Node,
1252 Pragmas_Before => Select_Pragmas,
1253 Statements => Statement_List),
1254 Abortable_Part => P_Abortable_Part);
1255
1256 -- Else error
1257
1258 else
1259 if Ada_83 then
1260 Error_Msg_BC ("OR or ELSE expected");
1261 else
1262 Error_Msg_BC ("OR or ELSE or THEN ABORT expected");
1263 end if;
1264
1265 Select_Node := Error;
1266 end if;
1267
1268 End_Statements;
1269
1270 -- Here we have a selective accept or an an asynchronous select (first
1271 -- token after SELECT is other than a designator token).
1272
1273 else
1274 -- If we have delay with no guard, could be asynchronous select
1275
1276 if Token = Tok_Delay then
1277 Delay_Stmnt := P_Delay_Statement;
1278 Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
1279
1280 -- Asynchronous select
1281
1282 if Token = Tok_Abort then
1283 Select_Node :=
1284 Make_Asynchronous_Select (Select_Sloc,
1285 Triggering_Alternative =>
1286 Make_Triggering_Alternative (Stmnt_Sloc,
1287 Triggering_Statement => Delay_Stmnt,
1288 Pragmas_Before => Select_Pragmas,
1289 Statements => Statement_List),
1290 Abortable_Part => P_Abortable_Part);
1291
1292 End_Statements;
1293 return Select_Node;
1294
1295 -- Delay which was not an asynchronous select. Must be a selective
1296 -- accept, and since at least one accept statement is required,
1297 -- we must have at least one OR phrase present.
1298
1299 else
1300 Alt_List := New_List (
1301 Make_Delay_Alternative (Stmnt_Sloc,
1302 Delay_Statement => Delay_Stmnt,
1303 Pragmas_Before => Select_Pragmas,
1304 Statements => Statement_List));
1305 T_Or;
1306 Alt_Pragmas := P_Pragmas_Opt;
1307 end if;
1308
1309 -- If not a delay statement, then must be another possibility for
1310 -- a selective accept alternative, or perhaps a guard is present
1311
1312 else
1313 Alt_List := New_List;
1314 Alt_Pragmas := Select_Pragmas;
1315 end if;
1316
1317 Select_Node := New_Node (N_Selective_Accept, Select_Sloc);
1318 Set_Select_Alternatives (Select_Node, Alt_List);
1319
1320 -- Scan out selective accept alternatives. On entry to this loop,
1321 -- we are just past a SELECT or OR token, and any pragmas that
1322 -- immediately follow the SELECT or OR are in Alt_Pragmas.
1323
1324 loop
1325 if Token = Tok_When then
1326
1327 if Present (Alt_Pragmas) then
1328 Error_Msg_SC ("pragmas may not precede guard");
1329 end if;
1330
1331 Scan; -- past WHEN
1332 Cond_Expr := P_Expression_No_Right_Paren;
1333 T_Arrow;
1334 Alt_Pragmas := P_Pragmas_Opt;
1335
1336 else
1337 Cond_Expr := Empty;
1338 end if;
1339
1340 if Token = Tok_Accept then
1341 Alternative := P_Accept_Alternative;
1342
1343 -- Check for junk attempt at asynchronous select using
1344 -- an Accept alternative as the triggering statement
1345
1346 if Token = Tok_Abort
1347 and then Is_Empty_List (Alt_List)
1348 and then No (Cond_Expr)
1349 then
1350 Error_Msg
1351 ("triggering statement must be entry call or delay",
1352 Sloc (Alternative));
1353 Scan; -- past junk ABORT
1354 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1355 End_Statements;
1356 return Error;
1357 end if;
1358
1359 elsif Token = Tok_Delay then
1360 Alternative := P_Delay_Alternative;
1361
1362 elsif Token = Tok_Terminate then
1363 Alternative := P_Terminate_Alternative;
1364
1365 else
1366 Error_Msg_SC
1367 ("Select alternative (ACCEPT, ABORT, DELAY) expected");
1368 Alternative := Error;
1369
1370 if Token = Tok_Semicolon then
1371 Scan; -- past junk semicolon
1372 end if;
1373 end if;
1374
1375 -- THEN ABORT at this stage is just junk
1376
1377 if Token = Tok_Abort then
1378 Error_Msg_SP ("misplaced `THEN ABORT`");
1379 Scan; -- past junk ABORT
1380 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1381 End_Statements;
1382 return Error;
1383
1384 else
1385 if Alternative /= Error then
1386 Set_Condition (Alternative, Cond_Expr);
1387 Set_Pragmas_Before (Alternative, Alt_Pragmas);
1388 Append (Alternative, Alt_List);
1389 end if;
1390
1391 exit when Token /= Tok_Or;
1392 end if;
1393
1394 T_Or;
1395 Alt_Pragmas := P_Pragmas_Opt;
1396 end loop;
1397
1398 if Token = Tok_Else then
1399 Scan; -- past ELSE
1400 Set_Else_Statements
1401 (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq));
1402
1403 if Token = Tok_Or then
1404 Error_Msg_SC ("select alternative cannot follow else part!");
1405 end if;
1406 end if;
1407
1408 End_Statements;
1409 end if;
1410
1411 return Select_Node;
1412 end P_Select_Statement;
1413
1414 -----------------------------
1415 -- 9.7.1 Selective Accept --
1416 -----------------------------
1417
1418 -- Parsed by P_Select_Statement (9.7)
1419
1420 ------------------
1421 -- 9.7.1 Guard --
1422 ------------------
1423
1424 -- Parsed by P_Select_Statement (9.7)
1425
1426 -------------------------------
1427 -- 9.7.1 Select Alternative --
1428 -------------------------------
1429
1430 -- SELECT_ALTERNATIVE ::=
1431 -- ACCEPT_ALTERNATIVE
1432 -- | DELAY_ALTERNATIVE
1433 -- | TERMINATE_ALTERNATIVE
1434
1435 -- Note: the guard preceding a select alternative is included as part
1436 -- of the node generated for a selective accept alternative.
1437
1438 -- Error recovery: cannot raise Error_Resync
1439
1440 -------------------------------
1441 -- 9.7.1 Accept Alternative --
1442 -------------------------------
1443
1444 -- ACCEPT_ALTERNATIVE ::=
1445 -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
1446
1447 -- Error_Recovery: Cannot raise Error_Resync
1448
1449 -- Note: the caller is responsible for setting the Pragmas_Before
1450 -- field of the returned N_Terminate_Alternative node.
1451
1452 function P_Accept_Alternative return Node_Id is
1453 Accept_Alt_Node : Node_Id;
1454
1455 begin
1456 Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr);
1457 Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement);
1458
1459 -- Note: the reason that we accept THEN ABORT as a terminator for
1460 -- the sequence of statements is for error recovery which allows
1461 -- for misuse of an accept statement as a triggering statememt.
1462
1463 Set_Statements
1464 (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
1465 return Accept_Alt_Node;
1466 end P_Accept_Alternative;
1467
1468 ------------------------------
1469 -- 9.7.1 Delay Alternative --
1470 ------------------------------
1471
1472 -- DELAY_ALTERNATIVE ::=
1473 -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
1474
1475 -- Error_Recovery: Cannot raise Error_Resync
1476
1477 -- Note: the caller is responsible for setting the Pragmas_Before
1478 -- field of the returned N_Terminate_Alternative node.
1479
1480 function P_Delay_Alternative return Node_Id is
1481 Delay_Alt_Node : Node_Id;
1482
1483 begin
1484 Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr);
1485 Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement);
1486
1487 -- Note: the reason that we accept THEN ABORT as a terminator for
1488 -- the sequence of statements is for error recovery which allows
1489 -- for misuse of an accept statement as a triggering statememt.
1490
1491 Set_Statements
1492 (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
1493 return Delay_Alt_Node;
1494 end P_Delay_Alternative;
1495
1496 ----------------------------------
1497 -- 9.7.1 Terminate Alternative --
1498 ----------------------------------
1499
1500 -- TERMINATE_ALTERNATIVE ::= terminate;
1501
1502 -- Error_Recovery: Cannot raise Error_Resync
1503
1504 -- Note: the caller is responsible for setting the Pragmas_Before
1505 -- field of the returned N_Terminate_Alternative node.
1506
1507 function P_Terminate_Alternative return Node_Id is
1508 Terminate_Alt_Node : Node_Id;
1509
1510 begin
1511 Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr);
1512 Scan; -- past TERMINATE
1513 TF_Semicolon;
1514
1515 -- For all other select alternatives, the sequence of statements
1516 -- after the alternative statement will swallow up any pragmas
1517 -- coming in this position. But the terminate alternative has no
1518 -- sequence of statements, so the pragmas here must be treated
1519 -- specially.
1520
1521 Set_Pragmas_After (Terminate_Alt_Node, P_Pragmas_Opt);
1522 return Terminate_Alt_Node;
1523 end P_Terminate_Alternative;
1524
1525 -----------------------------
1526 -- 9.7.2 Timed Entry Call --
1527 -----------------------------
1528
1529 -- Parsed by P_Select_Statement (9.7)
1530
1531 -----------------------------------
1532 -- 9.7.2 Entry Call Alternative --
1533 -----------------------------------
1534
1535 -- Parsed by P_Select_Statement (9.7)
1536
1537 -----------------------------------
1538 -- 9.7.3 Conditional Entry Call --
1539 -----------------------------------
1540
1541 -- Parsed by P_Select_Statement (9.7)
1542
1543 --------------------------------
1544 -- 9.7.4 Asynchronous Select --
1545 --------------------------------
1546
1547 -- Parsed by P_Select_Statement (9.7)
1548
1549 -----------------------------------
1550 -- 9.7.4 Triggering Alternative --
1551 -----------------------------------
1552
1553 -- Parsed by P_Select_Statement (9.7)
1554
1555 ---------------------------------
1556 -- 9.7.4 Triggering Statement --
1557 ---------------------------------
1558
1559 -- Parsed by P_Select_Statement (9.7)
1560
1561 ---------------------------
1562 -- 9.7.4 Abortable Part --
1563 ---------------------------
1564
1565 -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
1566
1567 -- The caller has verified that THEN ABORT is present, and Token is
1568 -- pointing to the ABORT on entry (or if not, then we have an error)
1569
1570 -- Error recovery: cannot raise Error_Resync
1571
1572 function P_Abortable_Part return Node_Id is
1573 Abortable_Part_Node : Node_Id;
1574
1575 begin
1576 Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr);
1577 T_Abort; -- scan past ABORT
1578
1579 if Ada_83 then
1580 Error_Msg_SP ("(Ada 83) asynchronous select not allowed!");
1581 end if;
1582
1583 Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq));
1584 return Abortable_Part_Node;
1585 end P_Abortable_Part;
1586
1587 --------------------------
1588 -- 9.8 Abort Statement --
1589 --------------------------
1590
1591 -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
1592
1593 -- The caller has checked that the initial token is ABORT
1594
1595 -- Error recovery: cannot raise Error_Resync
1596
1597 function P_Abort_Statement return Node_Id is
1598 Abort_Node : Node_Id;
1599
1600 begin
1601 Abort_Node := New_Node (N_Abort_Statement, Token_Ptr);
1602 Scan; -- past ABORT
1603 Set_Names (Abort_Node, New_List);
1604
1605 loop
1606 Append (P_Name, Names (Abort_Node));
1607 exit when Token /= Tok_Comma;
1608 Scan; -- past comma
1609 end loop;
1610
1611 TF_Semicolon;
1612 return Abort_Node;
1613 end P_Abort_Statement;
1614
1615 end Ch9;
Mirror of the offical gcc git repository hosted at gcc.gnu.org