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