Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/par-ch9.adb @ 111:04ced10e8804

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