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