?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix typo in t-dimode
[official-gcc.git] / gcc / ada / par-ch9.adb
blobe0d56318b3bdf7165292506336346aed8dfd9e71
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-2021, 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 Scopes (Scope.Last).Etyp := E_Name;
95 Scopes (Scope.Last).Ecol := Start_Column;
96 Scopes (Scope.Last).Sloc := Token_Ptr;
97 Scopes (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 Scopes (Scope.Last).Labl := Name_Node;
104 Current_Node := Name_Node;
105
106 if Token = Tok_Left_Paren then
107 Error_Msg_SC ("discriminant part not allowed in task body");
108 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
109 end if;
110
111 if Aspect_Specifications_Present then
112 Aspect_Sloc := Token_Ptr;
113 P_Aspect_Specifications (Dummy_Node, Semicolon => False);
114 end if;
115
116 TF_Is;
117
118 -- Task stub
119
120 if Token = Tok_Separate then
121 Scan; -- past SEPARATE
122 Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc);
123 Set_Defining_Identifier (Task_Node, Name_Node);
124
125 if Has_Aspects (Dummy_Node) then
126 Error_Msg
127 ("aspect specifications must come after SEPARATE",
128 Aspect_Sloc);
129 end if;
130
131 P_Aspect_Specifications (Task_Node, Semicolon => False);
132 TF_Semicolon;
133 Pop_Scope_Stack; -- remove unused entry
134
135 -- Task body
136
137 else
138 Task_Node := New_Node (N_Task_Body, Task_Sloc);
139 Set_Defining_Identifier (Task_Node, Name_Node);
140
141 -- Move the aspect specifications to the body node
142
143 if Has_Aspects (Dummy_Node) then
144 Move_Aspects (From => Dummy_Node, To => Task_Node);
145 end if;
146
147 Parse_Decls_Begin_End (Task_Node);
148
149 -- The statement list of a task body needs to include at least a
150 -- null statement, so if a parsing error produces an empty list,
151 -- patch it now.
152
153 if No (First (Statements
154 (Handled_Statement_Sequence (Task_Node))))
155 then
156 Set_Statements (Handled_Statement_Sequence (Task_Node),
157 New_List (Make_Null_Statement (Token_Ptr)));
158 end if;
159 end if;
160
161 return Task_Node;
162
163 -- Otherwise we must have a task declaration
164
165 else
166 if Token = Tok_Type then
167 Scan; -- past TYPE
168 Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc);
169 Name_Node := P_Defining_Identifier;
170 Set_Defining_Identifier (Task_Node, Name_Node);
171 Scopes (Scope.Last).Labl := Name_Node;
172 Current_Node := Name_Node;
173 Set_Discriminant_Specifications
174 (Task_Node, P_Known_Discriminant_Part_Opt);
175
176 else
177 Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc);
178 Name_Node := P_Defining_Identifier (C_Is);
179 Set_Defining_Identifier (Task_Node, Name_Node);
180 Scopes (Scope.Last).Labl := Name_Node;
181 Current_Node := Name_Node;
182
183 if Token = Tok_Left_Paren then
184 Error_Msg_SC ("discriminant part not allowed for single task");
185 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
186 end if;
187 end if;
188
189 -- Scan aspect specifications, don't eat the semicolon, since it
190 -- might not be there if we have an IS.
191
192 P_Aspect_Specifications (Task_Node, Semicolon => False);
193
194 -- Parse optional task definition. Note that P_Task_Definition scans
195 -- out the semicolon and possible aspect specifications as well as
196 -- the task definition itself.
197
198 if Token = Tok_Semicolon then
199
200 -- A little check, if the next token after semicolon is Entry,
201 -- then surely the semicolon should really be IS
202
203 Scan; -- past semicolon
204
205 if Token = Tok_Entry then
206 Error_Msg_SP -- CODEFIX
207 ("|"";"" should be IS");
208 Set_Task_Definition (Task_Node, P_Task_Definition);
209 else
210 Pop_Scope_Stack; -- Remove unused entry
211 end if;
212
213 -- Here we have a task definition
214
215 else
216 TF_Is; -- must have IS if no semicolon
217
218 -- Ada 2005 (AI-345)
219
220 if Token = Tok_New then
221 Scan; -- past NEW
222
223 Error_Msg_Ada_2005_Extension ("task interface");
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 Scopes (Scope.Last).Etyp := E_Name;
442 Scopes (Scope.Last).Ecol := Start_Column;
443 Scopes (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 Scopes (Scope.Last).Labl := Name_Node;
450 Current_Node := Name_Node;
451
452 if Token = Tok_Left_Paren then
453 Error_Msg_SC ("discriminant part not allowed in protected body");
454 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
455 end if;
456
457 if Aspect_Specifications_Present then
458 Aspect_Sloc := Token_Ptr;
459 P_Aspect_Specifications (Dummy_Node, Semicolon => False);
460 end if;
461
462 TF_Is;
463
464 -- Protected stub
465
466 if Token = Tok_Separate then
467 Scan; -- past SEPARATE
468
469 Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc);
470 Set_Defining_Identifier (Protected_Node, Name_Node);
471
472 if Has_Aspects (Dummy_Node) then
473 Error_Msg
474 ("aspect specifications must come after SEPARATE",
475 Aspect_Sloc);
476 end if;
477
478 P_Aspect_Specifications (Protected_Node, Semicolon => False);
479 TF_Semicolon;
480 Pop_Scope_Stack; -- remove unused entry
481
482 -- Protected body
483
484 else
485 Protected_Node := New_Node (N_Protected_Body, Protected_Sloc);
486 Set_Defining_Identifier (Protected_Node, Name_Node);
487
488 Move_Aspects (From => Dummy_Node, To => Protected_Node);
489 Set_Declarations (Protected_Node, P_Protected_Operation_Items);
490 End_Statements (Protected_Node);
491 end if;
492
493 return Protected_Node;
494
495 -- Otherwise we must have a protected declaration
496
497 else
498 if Token = Tok_Type then
499 Scan; -- past TYPE
500 Protected_Node :=
501 New_Node (N_Protected_Type_Declaration, Protected_Sloc);
502 Name_Node := P_Defining_Identifier (C_Is);
503 Set_Defining_Identifier (Protected_Node, Name_Node);
504 Scopes (Scope.Last).Labl := Name_Node;
505 Current_Node := Name_Node;
506 Set_Discriminant_Specifications
507 (Protected_Node, P_Known_Discriminant_Part_Opt);
508
509 else
510 Protected_Node :=
511 New_Node (N_Single_Protected_Declaration, Protected_Sloc);
512 Name_Node := P_Defining_Identifier (C_Is);
513 Set_Defining_Identifier (Protected_Node, Name_Node);
514
515 if Token = Tok_Left_Paren then
516 Error_Msg_SC
517 ("discriminant part not allowed for single protected");
518 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
519 end if;
520
521 Scopes (Scope.Last).Labl := Name_Node;
522 Current_Node := Name_Node;
523 end if;
524
525 P_Aspect_Specifications (Protected_Node, Semicolon => False);
526
527 -- Check for semicolon not followed by IS, this is something like
528
529 -- protected type r;
530
531 -- where we want
532
533 -- protected type r IS END;
534
535 if Token = Tok_Semicolon then
536 Save_Scan_State (Scan_State); -- at semicolon
537 Scan; -- past semicolon
538
539 if Token /= Tok_Is then
540 Restore_Scan_State (Scan_State);
541 Error_Msg_SC -- CODEFIX
542 ("missing IS");
543 Set_Protected_Definition (Protected_Node,
544 Make_Protected_Definition (Token_Ptr,
545 Visible_Declarations => Empty_List,
546 End_Label => Empty));
547
548 SIS_Entry_Active := False;
549 End_Statements
550 (Protected_Definition (Protected_Node), Protected_Node);
551 return Protected_Node;
552 end if;
553
554 Error_Msg_SP -- CODEFIX
555 ("|extra ""("" ignored");
556 end if;
557
558 T_Is;
559
560 -- Ada 2005 (AI-345)
561
562 if Token = Tok_New then
563 Scan; -- past NEW
564
565 Error_Msg_Ada_2005_Extension ("protected interface");
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_Ada_2005_Extension ("overriding indicator");
756
757 elsif Token = Tok_Entry then
758 Decl := P_Entry_Declaration;
759
760 Set_Must_Override (Decl, Is_Overriding);
761 Set_Must_Not_Override (Decl, Not_Overriding);
762
763 elsif Token = Tok_Function or else Token = Tok_Procedure then
764 Decl := P_Subprogram (Pf_Decl_Pexp);
765
766 Set_Must_Override (Specification (Decl), Is_Overriding);
767 Set_Must_Not_Override (Specification (Decl), Not_Overriding);
768
769 else
770 Error_Msg_SC -- CODEFIX
771 ("ENTRY, FUNCTION or PROCEDURE expected!");
772 end if;
773 end if;
774
775 return Decl;
776 end P_Entry_Or_Subprogram_With_Indicator;
777
778 Result : Node_Id := Empty;
779
780 -- Start of processing for P_Protected_Operation_Declaration_Opt
781
782 begin
783 -- This loop runs more than once only when a junk declaration is skipped
784
785 loop
786 case Token is
787 when Tok_Pragma =>
788 Result := P_Pragma;
789 exit;
790
791 when Tok_Not
792 | Tok_Overriding
793 =>
794 Result := P_Entry_Or_Subprogram_With_Indicator;
795 exit;
796
797 when Tok_Entry =>
798 Result := P_Entry_Declaration;
799 exit;
800
801 when Tok_Function
802 | Tok_Procedure
803 =>
804 Result := P_Subprogram (Pf_Decl_Pexp);
805 exit;
806
807 when Tok_Identifier =>
808 L := New_List;
809 P := Token_Ptr;
810 Skip_Declaration (L);
811
812 if Nkind (First (L)) = N_Object_Declaration then
813 Error_Msg
814 ("component must be declared in private part of " &
815 "protected type", P);
816 else
817 Error_Msg
818 ("illegal declaration in protected definition", P);
819 end if;
820 -- Continue looping
821
822 when Tok_For =>
823 Error_Msg_SC
824 ("representation clause not allowed in protected definition");
825 Resync_Past_Semicolon;
826 -- Continue looping
827
828 when others =>
829 if Token in Token_Class_Declk then
830 Error_Msg_SC ("illegal declaration in protected definition");
831 Resync_Past_Semicolon;
832
833 -- Return now to avoid cascaded messages if next declaration
834 -- is a valid component declaration.
835
836 Result := Error;
837 end if;
838
839 exit;
840 end case;
841 end loop;
842
843 if Nkind (Result) = N_Subprogram_Declaration
844 and then Nkind (Specification (Result)) =
845 N_Procedure_Specification
846 and then Null_Present (Specification (Result))
847 then
848 Error_Msg_N
849 ("protected operation cannot be a null procedure",
850 Null_Statement (Specification (Result)));
851 end if;
852
853 return Result;
854 end P_Protected_Operation_Declaration_Opt;
855
856 -----------------------------------
857 -- 9.4 Protected Operation Item --
858 -----------------------------------
859
860 -- PROTECTED_OPERATION_ITEM ::=
861 -- SUBPROGRAM_DECLARATION
862 -- | SUBPROGRAM_BODY
863 -- | ENTRY_BODY
864 -- | REPRESENTATION_CLAUSE
865
866 -- This procedure parses and returns a list of protected operation items
867
868 -- We are not currently permitting representation clauses to appear
869 -- as protected operation items, do we have to rethink this???
870
871 function P_Protected_Operation_Items return List_Id is
872 Item_List : List_Id;
873
874 begin
875 Item_List := New_List;
876
877 loop
878 if Token = Tok_Entry or else Bad_Spelling_Of (Tok_Entry) then
879 Append (P_Entry_Body, Item_List);
880
881 -- If the operation starts with procedure, function, or an overriding
882 -- indicator ("overriding" or "not overriding"), parse a subprogram.
883
884 elsif Token = Tok_Function or else Bad_Spelling_Of (Tok_Function)
885 or else
886 Token = Tok_Procedure or else Bad_Spelling_Of (Tok_Procedure)
887 or else
888 Token = Tok_Overriding or else Bad_Spelling_Of (Tok_Overriding)
889 or else
890 Token = Tok_Not or else Bad_Spelling_Of (Tok_Not)
891 then
892 Append (P_Subprogram (Pf_Decl_Pbod_Pexp), Item_List);
893
894 elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then
895 P_Pragmas_Opt (Item_List);
896
897 elsif Token = Tok_Private or else Bad_Spelling_Of (Tok_Private) then
898 Error_Msg_SC ("PRIVATE not allowed in protected body");
899 Scan; -- past PRIVATE
900
901 elsif Token = Tok_Identifier then
902 Error_Msg_SC ("all components must be declared in spec!");
903 Resync_Past_Semicolon;
904
905 elsif Token in Token_Class_Declk then
906 Error_Msg_SC ("declaration not allowed in protected body");
907 Resync_Past_Semicolon;
908
909 else
910 exit;
911 end if;
912 end loop;
913
914 return Item_List;
915 end P_Protected_Operation_Items;
916
917 ------------------------------
918 -- 9.5.2 Entry Declaration --
919 ------------------------------
920
921 -- ENTRY_DECLARATION ::=
922 -- [OVERRIDING_INDICATOR]
923 -- entry DEFINING_IDENTIFIER
924 -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE
925 -- [ASPECT_SPECIFICATIONS];
926
927 -- The caller has checked that the initial token is ENTRY, NOT or
928 -- OVERRIDING.
929
930 -- Error recovery: cannot raise Error_Resync
931
932 function P_Entry_Declaration return Node_Id is
933 Decl_Node : Node_Id;
934 Scan_State : Saved_Scan_State;
935
936 -- Flags for optional overriding indication. Two flags are needed,
937 -- to distinguish positive and negative overriding indicators from
938 -- the absence of any indicator.
939
940 Is_Overriding : Boolean := False;
941 Not_Overriding : Boolean := False;
942
943 begin
944 -- Ada 2005 (AI-397): Scan leading overriding indicator
945
946 if Token = Tok_Not then
947 Scan; -- past NOT
948
949 if Token = Tok_Overriding then
950 Scan; -- part OVERRIDING
951 Not_Overriding := True;
952 else
953 Error_Msg_SC -- CODEFIX
954 ("OVERRIDING expected!");
955 end if;
956
957 elsif Token = Tok_Overriding then
958 Scan; -- part OVERRIDING
959 Is_Overriding := True;
960 end if;
961
962 if Is_Overriding or else Not_Overriding then
963 if Ada_Version < Ada_2005 then
964 Error_Msg_Ada_2005_Extension ("overriding indicator");
965 elsif Token /= Tok_Entry then
966 Error_Msg_SC -- CODEFIX
967 ("ENTRY expected!");
968 end if;
969 end if;
970
971 Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
972 Scan; -- past ENTRY
973
974 Set_Defining_Identifier
975 (Decl_Node, P_Defining_Identifier (C_Left_Paren_Semicolon));
976
977 -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
978
979 if Token = Tok_Left_Paren then
980 Scan; -- past (
981
982 -- If identifier after left paren, could still be either
983
984 if Token = Tok_Identifier then
985 Save_Scan_State (Scan_State); -- at Id
986 Scan; -- past Id
987
988 -- If comma or colon after Id, must be Formal_Part
989
990 if Token = Tok_Comma or else Token = Tok_Colon then
991 Restore_Scan_State (Scan_State); -- to Id
992 Set_Parameter_Specifications (Decl_Node, P_Formal_Part);
993
994 -- Else if Id without comma or colon, must be discrete subtype
995 -- defn
996
997 else
998 Restore_Scan_State (Scan_State); -- to Id
999 Set_Discrete_Subtype_Definition
1000 (Decl_Node, P_Discrete_Subtype_Definition);
1001 T_Right_Paren;
1002 Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
1003 end if;
1004
1005 -- If no Id, must be discrete subtype definition
1006
1007 else
1008 Set_Discrete_Subtype_Definition
1009 (Decl_Node, P_Discrete_Subtype_Definition);
1010 T_Right_Paren;
1011 Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
1012 end if;
1013 end if;
1014
1015 if Is_Overriding then
1016 Set_Must_Override (Decl_Node);
1017 elsif Not_Overriding then
1018 Set_Must_Not_Override (Decl_Node);
1019 end if;
1020
1021 -- Error recovery check for illegal return
1022
1023 if Token = Tok_Return then
1024 Error_Msg_SC ("entry cannot have return value!");
1025 Scan;
1026 Discard_Junk_Node (P_Subtype_Indication);
1027 end if;
1028
1029 -- Error recovery check for improper use of entry barrier in spec
1030
1031 if Token = Tok_When then
1032 Error_Msg_SC ("barrier not allowed here (belongs in body)");
1033 Scan; -- past WHEN;
1034 Discard_Junk_Node (P_Expression_No_Right_Paren);
1035 end if;
1036
1037 P_Aspect_Specifications (Decl_Node);
1038 return Decl_Node;
1039
1040 exception
1041 when Error_Resync =>
1042 Resync_Past_Semicolon;
1043 return Error;
1044 end P_Entry_Declaration;
1045
1046 -----------------------------
1047 -- 9.5.2 Accept Statement --
1048 -----------------------------
1049
1050 -- ACCEPT_STATEMENT ::=
1051 -- accept entry_DIRECT_NAME
1052 -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do
1053 -- HANDLED_SEQUENCE_OF_STATEMENTS
1054 -- end [entry_IDENTIFIER]];
1055
1056 -- The caller has checked that the initial token is ACCEPT
1057
1058 -- Error recovery: cannot raise Error_Resync. If an error occurs, the
1059 -- scan is resynchronized past the next semicolon and control returns.
1060
1061 function P_Accept_Statement return Node_Id is
1062 Scan_State : Saved_Scan_State;
1063 Accept_Node : Node_Id;
1064 Hand_Seq : Node_Id;
1065
1066 begin
1067 Push_Scope_Stack;
1068 Scopes (Scope.Last).Sloc := Token_Ptr;
1069 Scopes (Scope.Last).Ecol := Start_Column;
1070
1071 Accept_Node := New_Node (N_Accept_Statement, Token_Ptr);
1072 Scan; -- past ACCEPT
1073 Scopes (Scope.Last).Labl := Token_Node;
1074 Current_Node := Token_Node;
1075
1076 Set_Entry_Direct_Name (Accept_Node, P_Identifier (C_Do));
1077
1078 -- Left paren could be (Entry_Index) or Formal_Part, determine which
1079
1080 if Token = Tok_Left_Paren then
1081 Save_Scan_State (Scan_State); -- at left paren
1082 Scan; -- past left paren
1083
1084 -- If first token after left paren not identifier, then Entry_Index
1085
1086 if Token /= Tok_Identifier then
1087 Set_Entry_Index (Accept_Node, P_Expression);
1088 T_Right_Paren;
1089 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
1090
1091 -- First token after left paren is identifier, could be either case
1092
1093 else -- Token = Tok_Identifier
1094 Scan; -- past identifier
1095
1096 -- If identifier followed by comma or colon, must be Formal_Part
1097
1098 if Token = Tok_Comma or else Token = Tok_Colon then
1099 Restore_Scan_State (Scan_State); -- to left paren
1100 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
1101
1102 -- If identifier not followed by comma/colon, must be entry index
1103
1104 else
1105 Restore_Scan_State (Scan_State); -- to left paren
1106 Scan; -- past left paren (again)
1107 Set_Entry_Index (Accept_Node, P_Expression);
1108 T_Right_Paren;
1109 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
1110 end if;
1111 end if;
1112 end if;
1113
1114 -- Scan out DO if present
1115
1116 if Token = Tok_Do then
1117 Scopes (Scope.Last).Etyp := E_Name;
1118 Scopes (Scope.Last).Lreq := False;
1119 Scan; -- past DO
1120 Hand_Seq := P_Handled_Sequence_Of_Statements;
1121 Set_Handled_Statement_Sequence (Accept_Node, Hand_Seq);
1122 End_Statements (Handled_Statement_Sequence (Accept_Node));
1123
1124 -- Exception handlers not allowed in Ada 95 node
1125
1126 if Present (Exception_Handlers (Hand_Seq)) then
1127 if Ada_Version = Ada_83 then
1128 Error_Msg_N
1129 ("(Ada 83) exception handlers in accept not allowed",
1130 First_Non_Pragma (Exception_Handlers (Hand_Seq)));
1131 end if;
1132 end if;
1133
1134 else
1135 Pop_Scope_Stack; -- discard unused entry
1136 TF_Semicolon;
1137 end if;
1138
1139 return Accept_Node;
1140
1141 -- If error, resynchronize past semicolon
1142
1143 exception
1144 when Error_Resync =>
1145 Resync_Past_Semicolon;
1146 Pop_Scope_Stack; -- discard unused entry
1147 return Error;
1148 end P_Accept_Statement;
1149
1150 ------------------------
1151 -- 9.5.2 Entry Index --
1152 ------------------------
1153
1154 -- Parsed by P_Expression (4.4)
1155
1156 --------------------------
1157 -- 9.5.2 Entry Barrier --
1158 --------------------------
1159
1160 -- ENTRY_BARRIER ::= when CONDITION
1161
1162 -- Error_Recovery: cannot raise Error_Resync
1163
1164 function P_Entry_Barrier return Node_Id is
1165 Bnode : Node_Id;
1166
1167 begin
1168 if Token = Tok_When then
1169 Scan; -- past WHEN;
1170 Bnode := P_Expression_No_Right_Paren;
1171
1172 if Token = Tok_Colon_Equal then
1173 Error_Msg_SC -- CODEFIX
1174 ("|"":="" should be ""=""");
1175 Scan;
1176 Bnode := P_Expression_No_Right_Paren;
1177 end if;
1178
1179 else
1180 T_When; -- to give error message
1181 Bnode := Error;
1182 end if;
1183
1184 return Bnode;
1185 end P_Entry_Barrier;
1186
1187 -----------------------
1188 -- 9.5.2 Entry Body --
1189 -----------------------
1190
1191 -- ENTRY_BODY ::=
1192 -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART
1193 -- [ASPECT_SPECIFICATIONS] ENTRY_BARRIER
1194 -- is
1195 -- DECLARATIVE_PART
1196 -- begin
1197 -- HANDLED_SEQUENCE_OF_STATEMENTS
1198 -- end [entry_IDENTIFIER];
1199
1200 -- The caller has checked that the initial token is ENTRY
1201
1202 -- Error_Recovery: cannot raise Error_Resync
1203
1204 function P_Entry_Body return Node_Id is
1205 Dummy_Node : Node_Id;
1206 Entry_Node : Node_Id;
1207 Formal_Part_Node : Node_Id;
1208 Name_Node : Node_Id;
1209
1210 begin
1211 Push_Scope_Stack;
1212 Entry_Node := New_Node (N_Entry_Body, Token_Ptr);
1213 Scan; -- past ENTRY
1214
1215 Scopes (Scope.Last).Ecol := Start_Column;
1216 Scopes (Scope.Last).Lreq := False;
1217 Scopes (Scope.Last).Etyp := E_Name;
1218 Scopes (Scope.Last).Sloc := Token_Ptr;
1219
1220 Name_Node := P_Defining_Identifier;
1221 Set_Defining_Identifier (Entry_Node, Name_Node);
1222 Scopes (Scope.Last).Labl := Name_Node;
1223 Current_Node := Name_Node;
1224
1225 Formal_Part_Node := P_Entry_Body_Formal_Part;
1226 Set_Entry_Body_Formal_Part (Entry_Node, Formal_Part_Node);
1227
1228 -- Ada 2012 (AI12-0169): Aspect specifications may appear on an entry
1229 -- body immediately after the formal part. Do not parse the aspect
1230 -- specifications directly because the "when" of the entry barrier may
1231 -- be interpreted as a misused "with".
1232
1233 if Token = Tok_With then
1234 P_Aspect_Specifications (Entry_Node, Semicolon => False);
1235 end if;
1236
1237 Set_Condition (Formal_Part_Node, P_Entry_Barrier);
1238
1239 -- Detect an illegal placement of aspect specifications following the
1240 -- entry barrier.
1241
1242 -- entry E ... when Barrier with Aspect is
1243
1244 if Token = Tok_With then
1245 Error_Msg_SC ("aspect specifications must come before entry barrier");
1246
1247 -- Consume the illegal aspects to allow for parsing to continue
1248
1249 Dummy_Node := New_Node (N_Entry_Body, Sloc (Entry_Node));
1250 P_Aspect_Specifications (Dummy_Node, Semicolon => False);
1251 end if;
1252
1253 TF_Is;
1254 Parse_Decls_Begin_End (Entry_Node);
1255
1256 return Entry_Node;
1257 end P_Entry_Body;
1258
1259 -----------------------------------
1260 -- 9.5.2 Entry Body Formal Part --
1261 -----------------------------------
1262
1263 -- ENTRY_BODY_FORMAL_PART ::=
1264 -- [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART]
1265
1266 -- Error_Recovery: cannot raise Error_Resync
1267
1268 function P_Entry_Body_Formal_Part return Node_Id is
1269 Fpart_Node : Node_Id;
1270 Scan_State : Saved_Scan_State;
1271
1272 begin
1273 Fpart_Node := New_Node (N_Entry_Body_Formal_Part, Token_Ptr);
1274
1275 -- See if entry index specification present, and if so parse it
1276
1277 if Token = Tok_Left_Paren then
1278 Save_Scan_State (Scan_State); -- at left paren
1279 Scan; -- past left paren
1280
1281 if Token = Tok_For then
1282 Set_Entry_Index_Specification
1283 (Fpart_Node, P_Entry_Index_Specification);
1284 T_Right_Paren;
1285 else
1286 Restore_Scan_State (Scan_State); -- to left paren
1287 end if;
1288
1289 -- Check for (common?) case of left paren omitted before FOR. This
1290 -- is a tricky case, because the corresponding missing left paren
1291 -- can cause real havoc if a formal part is present which gets
1292 -- treated as part of the discrete subtype definition of the
1293 -- entry index specification, so just give error and resynchronize
1294
1295 elsif Token = Tok_For then
1296 T_Left_Paren; -- to give error message
1297 Resync_To_When;
1298 end if;
1299
1300 Set_Parameter_Specifications (Fpart_Node, P_Parameter_Profile);
1301 return Fpart_Node;
1302 end P_Entry_Body_Formal_Part;
1303
1304 --------------------------------------
1305 -- 9.5.2 Entry Index Specification --
1306 --------------------------------------
1307
1308 -- ENTRY_INDEX_SPECIFICATION ::=
1309 -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
1310 -- [ASPECT_SPECIFICATION]
1311
1312 -- Error recovery: can raise Error_Resync
1313
1314 function P_Entry_Index_Specification return Node_Id is
1315 Iterator_Node : Node_Id;
1316
1317 begin
1318 Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr);
1319 T_For; -- past FOR
1320 Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier (C_In));
1321 T_In;
1322 Set_Discrete_Subtype_Definition
1323 (Iterator_Node, P_Discrete_Subtype_Definition);
1324
1325 if Token = Tok_With then
1326 P_Aspect_Specifications (Iterator_Node, False);
1327 end if;
1328
1329 return Iterator_Node;
1330 end P_Entry_Index_Specification;
1331
1332 ---------------------------------
1333 -- 9.5.3 Entry Call Statement --
1334 ---------------------------------
1335
1336 -- Parsed by P_Name (4.1). Within a select, an entry call is parsed
1337 -- by P_Select_Statement (9.7)
1338
1339 ------------------------------
1340 -- 9.5.4 Requeue Statement --
1341 ------------------------------
1342
1343 -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort];
1344
1345 -- The caller has checked that the initial token is requeue
1346
1347 -- Error recovery: can raise Error_Resync
1348
1349 function P_Requeue_Statement return Node_Id is
1350 Requeue_Node : Node_Id;
1351
1352 begin
1353 Requeue_Node := New_Node (N_Requeue_Statement, Token_Ptr);
1354 Scan; -- past REQUEUE
1355 Set_Name (Requeue_Node, P_Name);
1356
1357 if Token = Tok_With then
1358 Scan; -- past WITH
1359 T_Abort;
1360 Set_Abort_Present (Requeue_Node, True);
1361 end if;
1362
1363 TF_Semicolon;
1364 return Requeue_Node;
1365 end P_Requeue_Statement;
1366
1367 --------------------------
1368 -- 9.6 Delay Statement --
1369 --------------------------
1370
1371 -- DELAY_STATEMENT ::=
1372 -- DELAY_UNTIL_STATEMENT
1373 -- | DELAY_RELATIVE_STATEMENT
1374
1375 -- The caller has checked that the initial token is DELAY
1376
1377 -- Error recovery: cannot raise Error_Resync
1378
1379 function P_Delay_Statement return Node_Id is
1380 begin
1381 Scan; -- past DELAY
1382
1383 -- The following check for delay until misused in Ada 83 doesn't catch
1384 -- all cases, but it's good enough to catch most of them.
1385
1386 if Token_Name = Name_Until then
1387 Check_95_Keyword (Tok_Until, Tok_Left_Paren);
1388 Check_95_Keyword (Tok_Until, Tok_Identifier);
1389 end if;
1390
1391 if Token = Tok_Until then
1392 return P_Delay_Until_Statement;
1393 else
1394 return P_Delay_Relative_Statement;
1395 end if;
1396 end P_Delay_Statement;
1397
1398 --------------------------------
1399 -- 9.6 Delay Until Statement --
1400 --------------------------------
1401
1402 -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION;
1403
1404 -- The caller has checked that the initial token is DELAY, scanned it
1405 -- out and checked that the current token is UNTIL
1406
1407 -- Error recovery: cannot raise Error_Resync
1408
1409 function P_Delay_Until_Statement return Node_Id is
1410 Delay_Node : Node_Id;
1411
1412 begin
1413 Delay_Node := New_Node (N_Delay_Until_Statement, Prev_Token_Ptr);
1414 Scan; -- past UNTIL
1415 Set_Expression (Delay_Node, P_Expression_No_Right_Paren);
1416 TF_Semicolon;
1417 return Delay_Node;
1418 end P_Delay_Until_Statement;
1419
1420 -----------------------------------
1421 -- 9.6 Delay Relative Statement --
1422 -----------------------------------
1423
1424 -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION;
1425
1426 -- The caller has checked that the initial token is DELAY, scanned it
1427 -- out and determined that the current token is not UNTIL
1428
1429 -- Error recovery: cannot raise Error_Resync
1430
1431 function P_Delay_Relative_Statement return Node_Id is
1432 Delay_Node : Node_Id;
1433
1434 begin
1435 Delay_Node := New_Node (N_Delay_Relative_Statement, Prev_Token_Ptr);
1436 Set_Expression (Delay_Node, P_Expression_No_Right_Paren);
1437 Check_Simple_Expression_In_Ada_83 (Expression (Delay_Node));
1438 TF_Semicolon;
1439 return Delay_Node;
1440 end P_Delay_Relative_Statement;
1441
1442 ---------------------------
1443 -- 9.7 Select Statement --
1444 ---------------------------
1445
1446 -- SELECT_STATEMENT ::=
1447 -- SELECTIVE_ACCEPT
1448 -- | TIMED_ENTRY_CALL
1449 -- | CONDITIONAL_ENTRY_CALL
1450 -- | ASYNCHRONOUS_SELECT
1451
1452 -- SELECTIVE_ACCEPT ::=
1453 -- select
1454 -- [GUARD]
1455 -- SELECT_ALTERNATIVE
1456 -- {or
1457 -- [GUARD]
1458 -- SELECT_ALTERNATIVE
1459 -- [else
1460 -- SEQUENCE_OF_STATEMENTS]
1461 -- end select;
1462
1463 -- GUARD ::= when CONDITION =>
1464
1465 -- Note: the guard preceding a select alternative is included as part
1466 -- of the node generated for a selective accept alternative.
1467
1468 -- SELECT_ALTERNATIVE ::=
1469 -- ACCEPT_ALTERNATIVE
1470 -- | DELAY_ALTERNATIVE
1471 -- | TERMINATE_ALTERNATIVE
1472
1473 -- TIMED_ENTRY_CALL ::=
1474 -- select
1475 -- ENTRY_CALL_ALTERNATIVE
1476 -- or
1477 -- DELAY_ALTERNATIVE
1478 -- end select;
1479
1480 -- CONDITIONAL_ENTRY_CALL ::=
1481 -- select
1482 -- ENTRY_CALL_ALTERNATIVE
1483 -- else
1484 -- SEQUENCE_OF_STATEMENTS
1485 -- end select;
1486
1487 -- ENTRY_CALL_ALTERNATIVE ::=
1488 -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS]
1489
1490 -- ASYNCHRONOUS_SELECT ::=
1491 -- select
1492 -- TRIGGERING_ALTERNATIVE
1493 -- then abort
1494 -- ABORTABLE_PART
1495 -- end select;
1496
1497 -- TRIGGERING_ALTERNATIVE ::=
1498 -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS]
1499
1500 -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT
1501
1502 -- The caller has checked that the initial token is SELECT
1503
1504 -- Error recovery: can raise Error_Resync
1505
1506 function P_Select_Statement return Node_Id is
1507 Select_Node : Node_Id;
1508 Select_Sloc : Source_Ptr;
1509 Stmnt_Sloc : Source_Ptr;
1510 Ecall_Node : Node_Id;
1511 Alternative : Node_Id;
1512 Select_Pragmas : List_Id;
1513 Alt_Pragmas : List_Id;
1514 Statement_List : List_Id;
1515 Alt_List : List_Id;
1516 Cond_Expr : Node_Id;
1517 Delay_Stmnt : Node_Id;
1518
1519 begin
1520 Push_Scope_Stack;
1521 Scopes (Scope.Last).Etyp := E_Select;
1522 Scopes (Scope.Last).Ecol := Start_Column;
1523 Scopes (Scope.Last).Sloc := Token_Ptr;
1524 Scopes (Scope.Last).Labl := Error;
1525
1526 Select_Sloc := Token_Ptr;
1527 Scan; -- past SELECT
1528 Stmnt_Sloc := Token_Ptr;
1529 Select_Pragmas := P_Pragmas_Opt;
1530
1531 -- If first token after select is designator, then we have an entry
1532 -- call, which must be the start of a conditional entry call, timed
1533 -- entry call or asynchronous select
1534
1535 if Token in Token_Class_Desig then
1536
1537 -- Scan entry call statement
1538
1539 begin
1540 Ecall_Node := P_Name;
1541
1542 -- ?? The following two clauses exactly parallel code in ch5
1543 -- and should be combined sometime
1544
1545 if Nkind (Ecall_Node) = N_Indexed_Component then
1546 declare
1547 Prefix_Node : constant Node_Id := Prefix (Ecall_Node);
1548 Exprs_Node : constant List_Id := Expressions (Ecall_Node);
1549
1550 begin
1551 Change_Node (Ecall_Node, N_Procedure_Call_Statement);
1552 Set_Name (Ecall_Node, Prefix_Node);
1553 Set_Parameter_Associations (Ecall_Node, Exprs_Node);
1554 end;
1555
1556 elsif Nkind (Ecall_Node) = N_Function_Call then
1557 declare
1558 Fname_Node : constant Node_Id := Name (Ecall_Node);
1559 Params_List : constant List_Id :=
1560 Parameter_Associations (Ecall_Node);
1561
1562 begin
1563 Change_Node (Ecall_Node, N_Procedure_Call_Statement);
1564 Set_Name (Ecall_Node, Fname_Node);
1565 Set_Parameter_Associations (Ecall_Node, Params_List);
1566 end;
1567
1568 elsif Nkind (Ecall_Node) = N_Identifier
1569 or else Nkind (Ecall_Node) = N_Selected_Component
1570 then
1571 -- Case of a call to a parameterless entry
1572
1573 declare
1574 C_Node : constant Node_Id :=
1575 New_Node (N_Procedure_Call_Statement, Stmnt_Sloc);
1576 begin
1577 Set_Name (C_Node, Ecall_Node);
1578 Set_Parameter_Associations (C_Node, No_List);
1579 Ecall_Node := C_Node;
1580 end;
1581 end if;
1582
1583 TF_Semicolon;
1584
1585 exception
1586 when Error_Resync =>
1587 Resync_Past_Semicolon;
1588 return Error;
1589 end;
1590
1591 Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
1592
1593 -- OR follows, we have a timed entry call
1594
1595 if Token = Tok_Or then
1596 Scan; -- past OR
1597 Alt_Pragmas := P_Pragmas_Opt;
1598
1599 Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc);
1600 Set_Entry_Call_Alternative (Select_Node,
1601 Make_Entry_Call_Alternative (Stmnt_Sloc,
1602 Entry_Call_Statement => Ecall_Node,
1603 Pragmas_Before => Select_Pragmas,
1604 Statements => Statement_List));
1605
1606 -- Only possibility is delay alternative. If we have anything
1607 -- else, give message, and treat as conditional entry call.
1608
1609 if Token /= Tok_Delay then
1610 Error_Msg_SC
1611 ("only allowed alternative in timed entry call is delay!");
1612 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1613 Set_Delay_Alternative (Select_Node, Error);
1614
1615 else
1616 Set_Delay_Alternative (Select_Node, P_Delay_Alternative);
1617 Set_Pragmas_Before
1618 (Delay_Alternative (Select_Node), Alt_Pragmas);
1619 end if;
1620
1621 -- ELSE follows, we have a conditional entry call
1622
1623 elsif Token = Tok_Else then
1624 Scan; -- past ELSE
1625 Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc);
1626
1627 Set_Entry_Call_Alternative (Select_Node,
1628 Make_Entry_Call_Alternative (Stmnt_Sloc,
1629 Entry_Call_Statement => Ecall_Node,
1630 Pragmas_Before => Select_Pragmas,
1631 Statements => Statement_List));
1632
1633 Set_Else_Statements
1634 (Select_Node, P_Sequence_Of_Statements (SS_Sreq));
1635
1636 -- Only remaining case is THEN ABORT (asynchronous select)
1637
1638 elsif Token = Tok_Abort then
1639 Select_Node :=
1640 Make_Asynchronous_Select (Select_Sloc,
1641 Triggering_Alternative =>
1642 Make_Triggering_Alternative (Stmnt_Sloc,
1643 Triggering_Statement => Ecall_Node,
1644 Pragmas_Before => Select_Pragmas,
1645 Statements => Statement_List),
1646 Abortable_Part => P_Abortable_Part);
1647
1648 -- Else error
1649
1650 else
1651 if Ada_Version = Ada_83 then
1652 Error_Msg_BC ("OR or ELSE expected");
1653 else
1654 Error_Msg_BC ("OR or ELSE or `THEN ABORT` expected");
1655 end if;
1656
1657 Select_Node := Error;
1658 end if;
1659
1660 End_Statements;
1661
1662 -- Here we have a selective accept or an asynchronous select (first
1663 -- token after SELECT is other than a designator token).
1664
1665 else
1666 -- If we have delay with no guard, could be asynchronous select
1667
1668 if Token = Tok_Delay then
1669 Delay_Stmnt := P_Delay_Statement;
1670 Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
1671
1672 -- Asynchronous select
1673
1674 if Token = Tok_Abort then
1675 Select_Node :=
1676 Make_Asynchronous_Select (Select_Sloc,
1677 Triggering_Alternative =>
1678 Make_Triggering_Alternative (Stmnt_Sloc,
1679 Triggering_Statement => Delay_Stmnt,
1680 Pragmas_Before => Select_Pragmas,
1681 Statements => Statement_List),
1682 Abortable_Part => P_Abortable_Part);
1683
1684 End_Statements;
1685 return Select_Node;
1686
1687 -- Delay which was not an asynchronous select. Must be a selective
1688 -- accept, and since at least one accept statement is required,
1689 -- we must have at least one OR phrase present.
1690
1691 else
1692 Alt_List := New_List (
1693 Make_Delay_Alternative (Stmnt_Sloc,
1694 Delay_Statement => Delay_Stmnt,
1695 Pragmas_Before => Select_Pragmas,
1696 Statements => Statement_List));
1697 T_Or;
1698 Alt_Pragmas := P_Pragmas_Opt;
1699 end if;
1700
1701 -- If not a delay statement, then must be another possibility for
1702 -- a selective accept alternative, or perhaps a guard is present
1703
1704 else
1705 Alt_List := New_List;
1706 Alt_Pragmas := Select_Pragmas;
1707 end if;
1708
1709 Select_Node := New_Node (N_Selective_Accept, Select_Sloc);
1710 Set_Select_Alternatives (Select_Node, Alt_List);
1711
1712 -- Scan out selective accept alternatives. On entry to this loop,
1713 -- we are just past a SELECT or OR token, and any pragmas that
1714 -- immediately follow the SELECT or OR are in Alt_Pragmas.
1715
1716 loop
1717 if Token = Tok_When then
1718
1719 if Present (Alt_Pragmas) then
1720 Error_Msg_SC ("pragmas may not precede guard");
1721 end if;
1722
1723 Scan; -- past WHEN
1724 Cond_Expr := P_Expression_No_Right_Paren;
1725 T_Arrow;
1726 Alt_Pragmas := P_Pragmas_Opt;
1727
1728 else
1729 Cond_Expr := Empty;
1730 end if;
1731
1732 if Token = Tok_Accept then
1733 Alternative := P_Accept_Alternative;
1734
1735 -- Check for junk attempt at asynchronous select using
1736 -- an Accept alternative as the triggering statement
1737
1738 if Token = Tok_Abort
1739 and then Is_Empty_List (Alt_List)
1740 and then No (Cond_Expr)
1741 then
1742 Error_Msg
1743 ("triggering statement must be entry call or delay",
1744 Sloc (Alternative));
1745 Scan; -- past junk ABORT
1746 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1747 End_Statements;
1748 return Error;
1749 end if;
1750
1751 elsif Token = Tok_Delay then
1752 Alternative := P_Delay_Alternative;
1753
1754 elsif Token = Tok_Terminate then
1755 Alternative := P_Terminate_Alternative;
1756
1757 else
1758 Error_Msg_SC
1759 ("select alternative (ACCEPT, ABORT, DELAY) expected");
1760 Alternative := Error;
1761
1762 if Token = Tok_Semicolon then
1763 Scan; -- past junk semicolon
1764 end if;
1765 end if;
1766
1767 -- THEN ABORT at this stage is just junk
1768
1769 if Token = Tok_Abort then
1770 Error_Msg_SP ("misplaced `THEN ABORT`");
1771 Scan; -- past junk ABORT
1772 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1773 End_Statements;
1774 return Error;
1775
1776 else
1777 if Alternative /= Error then
1778 Set_Condition (Alternative, Cond_Expr);
1779 Set_Pragmas_Before (Alternative, Alt_Pragmas);
1780 Append (Alternative, Alt_List);
1781 end if;
1782
1783 exit when Token /= Tok_Or;
1784 end if;
1785
1786 T_Or;
1787 Alt_Pragmas := P_Pragmas_Opt;
1788 end loop;
1789
1790 if Token = Tok_Else then
1791 Scan; -- past ELSE
1792 Set_Else_Statements
1793 (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq));
1794
1795 if Token = Tok_Or then
1796 Error_Msg_SC ("select alternative cannot follow else part!");
1797 end if;
1798 end if;
1799
1800 End_Statements;
1801 end if;
1802
1803 return Select_Node;
1804 end P_Select_Statement;
1805
1806 -----------------------------
1807 -- 9.7.1 Selective Accept --
1808 -----------------------------
1809
1810 -- Parsed by P_Select_Statement (9.7)
1811
1812 ------------------
1813 -- 9.7.1 Guard --
1814 ------------------
1815
1816 -- Parsed by P_Select_Statement (9.7)
1817
1818 -------------------------------
1819 -- 9.7.1 Select Alternative --
1820 -------------------------------
1821
1822 -- SELECT_ALTERNATIVE ::=
1823 -- ACCEPT_ALTERNATIVE
1824 -- | DELAY_ALTERNATIVE
1825 -- | TERMINATE_ALTERNATIVE
1826
1827 -- Note: the guard preceding a select alternative is included as part
1828 -- of the node generated for a selective accept alternative.
1829
1830 -- Error recovery: cannot raise Error_Resync
1831
1832 -------------------------------
1833 -- 9.7.1 Accept Alternative --
1834 -------------------------------
1835
1836 -- ACCEPT_ALTERNATIVE ::=
1837 -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
1838
1839 -- Error_Recovery: Cannot raise Error_Resync
1840
1841 -- Note: the caller is responsible for setting the Pragmas_Before
1842 -- field of the returned N_Terminate_Alternative node.
1843
1844 function P_Accept_Alternative return Node_Id is
1845 Accept_Alt_Node : Node_Id;
1846
1847 begin
1848 Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr);
1849 Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement);
1850
1851 -- Note: the reason that we accept THEN ABORT as a terminator for
1852 -- the sequence of statements is for error recovery which allows
1853 -- for misuse of an accept statement as a triggering statement.
1854
1855 Set_Statements
1856 (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
1857 return Accept_Alt_Node;
1858 end P_Accept_Alternative;
1859
1860 ------------------------------
1861 -- 9.7.1 Delay Alternative --
1862 ------------------------------
1863
1864 -- DELAY_ALTERNATIVE ::=
1865 -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
1866
1867 -- Error_Recovery: Cannot raise Error_Resync
1868
1869 -- Note: the caller is responsible for setting the Pragmas_Before
1870 -- field of the returned N_Terminate_Alternative node.
1871
1872 function P_Delay_Alternative return Node_Id is
1873 Delay_Alt_Node : Node_Id;
1874
1875 begin
1876 Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr);
1877 Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement);
1878
1879 -- Note: the reason that we accept THEN ABORT as a terminator for
1880 -- the sequence of statements is for error recovery which allows
1881 -- for misuse of an accept statement as a triggering statement.
1882
1883 Set_Statements
1884 (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
1885 return Delay_Alt_Node;
1886 end P_Delay_Alternative;
1887
1888 ----------------------------------
1889 -- 9.7.1 Terminate Alternative --
1890 ----------------------------------
1891
1892 -- TERMINATE_ALTERNATIVE ::= terminate;
1893
1894 -- Error_Recovery: Cannot raise Error_Resync
1895
1896 -- Note: the caller is responsible for setting the Pragmas_Before
1897 -- field of the returned N_Terminate_Alternative node.
1898
1899 function P_Terminate_Alternative return Node_Id is
1900 Terminate_Alt_Node : Node_Id;
1901
1902 begin
1903 Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr);
1904 Scan; -- past TERMINATE
1905 TF_Semicolon;
1906
1907 -- For all other select alternatives, the sequence of statements
1908 -- after the alternative statement will swallow up any pragmas
1909 -- coming in this position. But the terminate alternative has no
1910 -- sequence of statements, so the pragmas here must be treated
1911 -- specially.
1912
1913 Set_Pragmas_After (Terminate_Alt_Node, P_Pragmas_Opt);
1914 return Terminate_Alt_Node;
1915 end P_Terminate_Alternative;
1916
1917 -----------------------------
1918 -- 9.7.2 Timed Entry Call --
1919 -----------------------------
1920
1921 -- Parsed by P_Select_Statement (9.7)
1922
1923 -----------------------------------
1924 -- 9.7.2 Entry Call Alternative --
1925 -----------------------------------
1926
1927 -- Parsed by P_Select_Statement (9.7)
1928
1929 -----------------------------------
1930 -- 9.7.3 Conditional Entry Call --
1931 -----------------------------------
1932
1933 -- Parsed by P_Select_Statement (9.7)
1934
1935 --------------------------------
1936 -- 9.7.4 Asynchronous Select --
1937 --------------------------------
1938
1939 -- Parsed by P_Select_Statement (9.7)
1940
1941 -----------------------------------
1942 -- 9.7.4 Triggering Alternative --
1943 -----------------------------------
1944
1945 -- Parsed by P_Select_Statement (9.7)
1946
1947 ---------------------------------
1948 -- 9.7.4 Triggering Statement --
1949 ---------------------------------
1950
1951 -- Parsed by P_Select_Statement (9.7)
1952
1953 ---------------------------
1954 -- 9.7.4 Abortable Part --
1955 ---------------------------
1956
1957 -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
1958
1959 -- The caller has verified that THEN ABORT is present, and Token is
1960 -- pointing to the ABORT on entry (or if not, then we have an error)
1961
1962 -- Error recovery: cannot raise Error_Resync
1963
1964 function P_Abortable_Part return Node_Id is
1965 Abortable_Part_Node : Node_Id;
1966
1967 begin
1968 Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr);
1969 T_Abort; -- scan past ABORT
1970
1971 if Ada_Version = Ada_83 then
1972 Error_Msg_SP ("(Ada 83) asynchronous select not allowed!");
1973 end if;
1974
1975 Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq));
1976 return Abortable_Part_Node;
1977 end P_Abortable_Part;
1978
1979 --------------------------
1980 -- 9.8 Abort Statement --
1981 --------------------------
1982
1983 -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
1984
1985 -- The caller has checked that the initial token is ABORT
1986
1987 -- Error recovery: cannot raise Error_Resync
1988
1989 function P_Abort_Statement return Node_Id is
1990 Abort_Node : Node_Id;
1991
1992 begin
1993 Abort_Node := New_Node (N_Abort_Statement, Token_Ptr);
1994 Scan; -- past ABORT
1995 Set_Names (Abort_Node, New_List);
1996
1997 loop
1998 Append (P_Name, Names (Abort_Node));
1999 exit when Token /= Tok_Comma;
2000 Scan; -- past comma
2001 end loop;
2002
2003 TF_Semicolon;
2004 return Abort_Node;
2005 end P_Abort_Statement;
2006
2007 end Ch9;
Mirror of the offical gcc git repository hosted at gcc.gnu.org