1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks (All_Checks);
27 -- Turn off subprogram body ordering check. Subprograms are in order by RM
28 -- section rather than alphabetical.
33 -- Local subprograms, used only in this chapter
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;
49 -----------------------------
50 -- 9.1 Task (also 10.1.3) --
51 -----------------------------
53 -- TASK_TYPE_DECLARATION ::=
54 -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
55 -- [ASPECT_SPECIFICATIONS]
56 -- [is [new INTERFACE_LIST with] TASK_DEFINITION];
58 -- SINGLE_TASK_DECLARATION ::=
59 -- task DEFINING_IDENTIFIER
60 -- [ASPECT_SPECIFICATIONS]
61 -- [is [new INTERFACE_LIST with] TASK_DEFINITION];
64 -- task body DEFINING_IDENTIFIER is
67 -- HANDLED_SEQUENCE_OF_STATEMENTS
68 -- end [task_IDENTIFIER]
71 -- task body DEFINING_IDENTIFIER is separate;
73 -- This routine scans out a task declaration, task body, or task stub
75 -- The caller has checked that the initial token is TASK and scanned
76 -- past it, so that Token is set to the token after TASK
78 -- Error recovery: cannot raise Error_Resync
80 function P_Task return Node_Id is
83 Task_Sloc : Source_Ptr;
87 Scope.Table (Scope.Last).Etyp := E_Name;
88 Scope.Table (Scope.Last).Ecol := Start_Column;
89 Scope.Table (Scope.Last).Sloc := Token_Ptr;
90 Scope.Table (Scope.Last).Lreq := False;
91 Task_Sloc := Prev_Token_Ptr;
93 if Token = Tok_Body then
95 Name_Node := P_Defining_Identifier (C_Is);
96 Scope.Table (Scope.Last).Labl := Name_Node;
98 if Token = Tok_Left_Paren then
99 Error_Msg_SC ("discriminant part not allowed in task body");
100 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
107 if Token = Tok_Separate then
108 Scan; -- past SEPARATE
109 Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc);
110 Set_Defining_Identifier (Task_Node, Name_Node);
112 Pop_Scope_Stack; -- remove unused entry
117 Task_Node := New_Node (N_Task_Body, Task_Sloc);
118 Set_Defining_Identifier (Task_Node, Name_Node);
119 Parse_Decls_Begin_End (Task_Node);
124 -- Otherwise we must have a task declaration
127 if Token = Tok_Type then
129 Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc);
130 Name_Node := P_Defining_Identifier;
131 Set_Defining_Identifier (Task_Node, Name_Node);
132 Scope.Table (Scope.Last).Labl := Name_Node;
133 Set_Discriminant_Specifications
134 (Task_Node, P_Known_Discriminant_Part_Opt);
137 Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc);
138 Name_Node := P_Defining_Identifier (C_Is);
139 Set_Defining_Identifier (Task_Node, Name_Node);
140 Scope.Table (Scope.Last).Labl := Name_Node;
142 if Token = Tok_Left_Paren then
143 Error_Msg_SC ("discriminant part not allowed for single task");
144 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
148 -- Scan aspect specifications, don't eat the semicolon, since it
149 -- might not be there if we have an IS.
151 P_Aspect_Specifications (Task_Node, Semicolon => False);
153 -- Parse optional task definition. Note that P_Task_Definition scans
154 -- out the semicolon and possible aspect specifications as well as
155 -- the task definition itself.
157 if Token = Tok_Semicolon then
159 -- A little check, if the next token after semicolon is Entry,
160 -- then surely the semicolon should really be IS
162 Scan; -- past semicolon
164 if Token = Tok_Entry then
165 Error_Msg_SP -- CODEFIX
166 ("|"";"" should be IS");
167 Set_Task_Definition (Task_Node, P_Task_Definition);
169 Pop_Scope_Stack; -- Remove unused entry
172 -- Here we have a task definition
175 TF_Is; -- must have IS if no semicolon
179 if Token = Tok_New then
182 if Ada_Version < Ada_2005 then
183 Error_Msg_SP ("task interface is an Ada 2005 extension");
184 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
187 Set_Interface_List (Task_Node, New_List);
190 Append (P_Qualified_Simple_Name, Interface_List (Task_Node));
191 exit when Token /= Tok_And;
195 if Token /= Tok_With then
196 Error_Msg_SC -- CODEFIX
202 if Token = Tok_Private then
203 Error_Msg_SP -- CODEFIX
204 ("PRIVATE not allowed in task type declaration");
208 Set_Task_Definition (Task_Node, P_Task_Definition);
215 --------------------------------
216 -- 9.1 Task Type Declaration --
217 --------------------------------
219 -- Parsed by P_Task (9.1)
221 ----------------------------------
222 -- 9.1 Single Task Declaration --
223 ----------------------------------
225 -- Parsed by P_Task (9.1)
227 --------------------------
228 -- 9.1 Task Definition --
229 --------------------------
231 -- TASK_DEFINITION ::=
235 -- end [task_IDENTIFIER];
237 -- The caller has already made the scope stack entry
239 -- Note: there is a small deviation from official syntax here in that we
240 -- regard the semicolon after end as part of the Task_Definition, and in
241 -- the official syntax, it's part of the enclosing declaration. The reason
242 -- for this deviation is that otherwise the end processing would have to
243 -- be special cased, which would be a nuisance!
245 -- Error recovery: cannot raise Error_Resync
247 function P_Task_Definition return Node_Id is
251 Def_Node := New_Node (N_Task_Definition, Token_Ptr);
252 Set_Visible_Declarations (Def_Node, P_Task_Items);
254 if Token = Tok_Private then
255 Scan; -- past PRIVATE
256 Set_Private_Declarations (Def_Node, P_Task_Items);
258 -- Deal gracefully with multiple PRIVATE parts
260 while Token = Tok_Private loop
261 Error_Msg_SC ("only one private part allowed per task");
262 Scan; -- past PRIVATE
263 Append_List (P_Task_Items, Private_Declarations (Def_Node));
267 End_Statements (Def_Node);
269 end P_Task_Definition;
275 -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE
277 -- This subprogram scans a (possibly empty) list of task items and pragmas
279 -- Error recovery: cannot raise Error_Resync
281 -- Note: a pragma can also be returned in this position
283 function P_Task_Items return List_Id is
286 Decl_Sloc : Source_Ptr;
289 -- Get rid of active SIS entry from outer scope. This means we will
290 -- miss some nested cases, but it doesn't seem worth the effort. See
291 -- discussion in Par for further details
293 SIS_Entry_Active := False;
295 -- Loop to scan out task items
300 Decl_Sloc := Token_Ptr;
302 if Token = Tok_Pragma then
303 Append (P_Pragma, Items);
305 -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING
306 -- may begin an entry declaration.
308 elsif Token = Tok_Entry
309 or else Token = Tok_Not
310 or else Token = Tok_Overriding
312 Append (P_Entry_Declaration, Items);
314 elsif Token = Tok_For then
315 -- Representation clause in task declaration. The only rep
316 -- clause which is legal in a protected is an address clause,
317 -- so that is what we try to scan out.
319 Item_Node := P_Representation_Clause;
321 if Nkind (Item_Node) = N_At_Clause then
322 Append (Item_Node, Items);
324 elsif Nkind (Item_Node) = N_Attribute_Definition_Clause
325 and then Chars (Item_Node) = Name_Address
327 Append (Item_Node, Items);
331 ("the only representation clause " &
332 "allowed here is an address clause!", Decl_Sloc);
335 elsif Token = Tok_Identifier
336 or else Token in Token_Class_Declk
338 Error_Msg_SC ("illegal declaration in task definition");
339 Resync_Past_Semicolon;
353 -- Parsed by P_Task (9.1)
355 ----------------------------------
356 -- 9.4 Protected (also 10.1.3) --
357 ----------------------------------
359 -- PROTECTED_TYPE_DECLARATION ::=
360 -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
361 -- [ASPECT_SPECIFICATIONS]
362 -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
364 -- SINGLE_PROTECTED_DECLARATION ::=
365 -- protected DEFINING_IDENTIFIER
366 -- [ASPECT_SPECIFICATIONS]
367 -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
369 -- PROTECTED_BODY ::=
370 -- protected body DEFINING_IDENTIFIER is
371 -- {PROTECTED_OPERATION_ITEM}
372 -- end [protected_IDENTIFIER];
374 -- PROTECTED_BODY_STUB ::=
375 -- protected body DEFINING_IDENTIFIER is separate;
377 -- This routine scans out a protected declaration, protected body
378 -- or a protected stub.
380 -- The caller has checked that the initial token is PROTECTED and
381 -- scanned past it, so Token is set to the following token.
383 -- Error recovery: cannot raise Error_Resync
385 function P_Protected return Node_Id is
387 Protected_Node : Node_Id;
388 Protected_Sloc : Source_Ptr;
389 Scan_State : Saved_Scan_State;
393 Scope.Table (Scope.Last).Etyp := E_Name;
394 Scope.Table (Scope.Last).Ecol := Start_Column;
395 Scope.Table (Scope.Last).Lreq := False;
396 Protected_Sloc := Prev_Token_Ptr;
398 if Token = Tok_Body then
400 Name_Node := P_Defining_Identifier (C_Is);
401 Scope.Table (Scope.Last).Labl := Name_Node;
403 if Token = Tok_Left_Paren then
404 Error_Msg_SC ("discriminant part not allowed in protected body");
405 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
412 if Token = Tok_Separate then
413 Scan; -- past SEPARATE
414 Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc);
415 Set_Defining_Identifier (Protected_Node, Name_Node);
417 Pop_Scope_Stack; -- remove unused entry
422 Protected_Node := New_Node (N_Protected_Body, Protected_Sloc);
423 Set_Defining_Identifier (Protected_Node, Name_Node);
424 Set_Declarations (Protected_Node, P_Protected_Operation_Items);
425 End_Statements (Protected_Node);
428 return Protected_Node;
430 -- Otherwise we must have a protected declaration
433 if Token = Tok_Type then
436 New_Node (N_Protected_Type_Declaration, Protected_Sloc);
437 Name_Node := P_Defining_Identifier (C_Is);
438 Set_Defining_Identifier (Protected_Node, Name_Node);
439 Scope.Table (Scope.Last).Labl := Name_Node;
440 Set_Discriminant_Specifications
441 (Protected_Node, P_Known_Discriminant_Part_Opt);
445 New_Node (N_Single_Protected_Declaration, Protected_Sloc);
446 Name_Node := P_Defining_Identifier (C_Is);
447 Set_Defining_Identifier (Protected_Node, Name_Node);
449 if Token = Tok_Left_Paren then
451 ("discriminant part not allowed for single protected");
452 Discard_Junk_List (P_Known_Discriminant_Part_Opt);
455 Scope.Table (Scope.Last).Labl := Name_Node;
458 P_Aspect_Specifications (Protected_Node, Semicolon => False);
460 -- Check for semicolon not followed by IS, this is something like
466 -- protected type r IS END;
468 if Token = Tok_Semicolon then
469 Save_Scan_State (Scan_State); -- at semicolon
470 Scan; -- past semicolon
472 if Token /= Tok_Is then
473 Restore_Scan_State (Scan_State);
474 Error_Msg_SC -- CODEFIX
476 Set_Protected_Definition (Protected_Node,
477 Make_Protected_Definition (Token_Ptr,
478 Visible_Declarations => Empty_List,
479 End_Label => Empty));
481 SIS_Entry_Active := False;
483 (Protected_Definition (Protected_Node), Protected_Node);
484 return Protected_Node;
487 Error_Msg_SP -- CODEFIX
488 ("|extra ""("" ignored");
495 if Token = Tok_New then
498 if Ada_Version < Ada_2005 then
499 Error_Msg_SP ("protected interface is an Ada 2005 extension");
500 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
503 Set_Interface_List (Protected_Node, New_List);
506 Append (P_Qualified_Simple_Name,
507 Interface_List (Protected_Node));
509 exit when Token /= Tok_And;
513 if Token /= Tok_With then
514 Error_Msg_SC -- CODEFIX
521 Set_Protected_Definition (Protected_Node, P_Protected_Definition);
522 return Protected_Node;
526 -------------------------------------
527 -- 9.4 Protected Type Declaration --
528 -------------------------------------
530 -- Parsed by P_Protected (9.4)
532 ---------------------------------------
533 -- 9.4 Single Protected Declaration --
534 ---------------------------------------
536 -- Parsed by P_Protected (9.4)
538 -------------------------------
539 -- 9.4 Protected Definition --
540 -------------------------------
542 -- PROTECTED_DEFINITION ::=
543 -- {PROTECTED_OPERATION_DECLARATION}
545 -- {PROTECTED_ELEMENT_DECLARATION}]
546 -- end [protected_IDENTIFIER]
548 -- PROTECTED_ELEMENT_DECLARATION ::=
549 -- PROTECTED_OPERATION_DECLARATION
550 -- | COMPONENT_DECLARATION
552 -- The caller has already established the scope stack entry
554 -- Error recovery: cannot raise Error_Resync
556 function P_Protected_Definition return Node_Id is
561 Def_Node := New_Node (N_Protected_Definition, Token_Ptr);
563 -- Get rid of active SIS entry from outer scope. This means we will
564 -- miss some nested cases, but it doesn't seem worth the effort. See
565 -- discussion in Par for further details
567 SIS_Entry_Active := False;
569 -- Loop to scan visible declarations (protected operation declarations)
571 Set_Visible_Declarations (Def_Node, New_List);
574 Item_Node := P_Protected_Operation_Declaration_Opt;
575 exit when No (Item_Node);
576 Append (Item_Node, Visible_Declarations (Def_Node));
579 -- Deal with PRIVATE part (including graceful handling of multiple
582 Private_Loop : while Token = Tok_Private loop
583 if No (Private_Declarations (Def_Node)) then
584 Set_Private_Declarations (Def_Node, New_List);
586 Error_Msg_SC ("duplicate private part");
589 Scan; -- past PRIVATE
591 Declaration_Loop : loop
592 if Token = Tok_Identifier then
593 P_Component_Items (Private_Declarations (Def_Node));
595 Item_Node := P_Protected_Operation_Declaration_Opt;
596 exit Declaration_Loop when No (Item_Node);
597 Append (Item_Node, Private_Declarations (Def_Node));
599 end loop Declaration_Loop;
600 end loop Private_Loop;
602 End_Statements (Def_Node);
604 end P_Protected_Definition;
606 ------------------------------------------
607 -- 9.4 Protected Operation Declaration --
608 ------------------------------------------
610 -- PROTECTED_OPERATION_DECLARATION ::=
611 -- SUBPROGRAM_DECLARATION
612 -- | ENTRY_DECLARATION
613 -- | REPRESENTATION_CLAUSE
615 -- Error recovery: cannot raise Error_Resync
617 -- Note: a pragma can also be returned in this position
619 -- We are not currently permitting representation clauses to appear as
620 -- protected operation declarations, do we have to rethink this???
622 function P_Protected_Operation_Declaration_Opt return Node_Id is
626 function P_Entry_Or_Subprogram_With_Indicator return Node_Id;
627 -- Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding
628 -- indicator. The caller has checked that the initial token is NOT or
631 ------------------------------------------
632 -- P_Entry_Or_Subprogram_With_Indicator --
633 ------------------------------------------
635 function P_Entry_Or_Subprogram_With_Indicator return Node_Id is
636 Decl : Node_Id := Error;
637 Is_Overriding : Boolean := False;
638 Not_Overriding : Boolean := False;
641 if Token = Tok_Not then
644 if Token = Tok_Overriding then
645 Scan; -- past OVERRIDING
646 Not_Overriding := True;
648 Error_Msg_SC -- CODEFIX
649 ("OVERRIDING expected!");
653 Scan; -- past OVERRIDING
654 Is_Overriding := True;
657 if Is_Overriding or else Not_Overriding then
658 if Ada_Version < Ada_2005 then
659 Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
660 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
662 elsif Token = Tok_Entry then
663 Decl := P_Entry_Declaration;
665 Set_Must_Override (Decl, Is_Overriding);
666 Set_Must_Not_Override (Decl, Not_Overriding);
668 elsif Token = Tok_Function or else Token = Tok_Procedure then
669 Decl := P_Subprogram (Pf_Decl_Pexp);
671 Set_Must_Override (Specification (Decl), Is_Overriding);
672 Set_Must_Not_Override (Specification (Decl), Not_Overriding);
675 Error_Msg_SC -- CODEFIX
676 ("ENTRY, FUNCTION or PROCEDURE expected!");
681 end P_Entry_Or_Subprogram_With_Indicator;
683 -- Start of processing for P_Protected_Operation_Declaration_Opt
686 -- This loop runs more than once only when a junk declaration
690 if Token = Tok_Pragma then
693 elsif Token = Tok_Not or else Token = Tok_Overriding then
694 return P_Entry_Or_Subprogram_With_Indicator;
696 elsif Token = Tok_Entry then
697 return P_Entry_Declaration;
699 elsif Token = Tok_Function or else Token = Tok_Procedure then
700 return P_Subprogram (Pf_Decl_Pexp);
702 elsif Token = Tok_Identifier then
705 Skip_Declaration (L);
707 if Nkind (First (L)) = N_Object_Declaration then
709 ("component must be declared in private part of " &
710 "protected type", P);
713 ("illegal declaration in protected definition", P);
716 elsif Token in Token_Class_Declk then
717 Error_Msg_SC ("illegal declaration in protected definition");
718 Resync_Past_Semicolon;
720 -- Return now to avoid cascaded messages if next declaration
721 -- is a valid component declaration.
725 elsif Token = Tok_For then
727 ("representation clause not allowed in protected definition");
728 Resync_Past_Semicolon;
734 end P_Protected_Operation_Declaration_Opt;
736 -----------------------------------
737 -- 9.4 Protected Operation Item --
738 -----------------------------------
740 -- PROTECTED_OPERATION_ITEM ::=
741 -- SUBPROGRAM_DECLARATION
744 -- | REPRESENTATION_CLAUSE
746 -- This procedure parses and returns a list of protected operation items
748 -- We are not currently permitting representation clauses to appear
749 -- as protected operation items, do we have to rethink this???
751 function P_Protected_Operation_Items return List_Id is
755 Item_List := New_List;
758 if Token = Tok_Entry or else Bad_Spelling_Of (Tok_Entry) then
759 Append (P_Entry_Body, Item_List);
761 -- If the operation starts with procedure, function, or an overriding
762 -- indicator ("overriding" or "not overriding"), parse a subprogram.
764 elsif Token = Tok_Function or else Bad_Spelling_Of (Tok_Function)
766 Token = Tok_Procedure or else Bad_Spelling_Of (Tok_Procedure)
768 Token = Tok_Overriding or else Bad_Spelling_Of (Tok_Overriding)
770 Token = Tok_Not or else Bad_Spelling_Of (Tok_Not)
772 Append (P_Subprogram (Pf_Decl_Pbod_Pexp), Item_List);
774 elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then
775 P_Pragmas_Opt (Item_List);
777 elsif Token = Tok_Private or else Bad_Spelling_Of (Tok_Private) then
778 Error_Msg_SC ("PRIVATE not allowed in protected body");
779 Scan; -- past PRIVATE
781 elsif Token = Tok_Identifier then
782 Error_Msg_SC ("all components must be declared in spec!");
783 Resync_Past_Semicolon;
785 elsif Token in Token_Class_Declk then
786 Error_Msg_SC ("this declaration not allowed in protected body");
787 Resync_Past_Semicolon;
795 end P_Protected_Operation_Items;
797 ------------------------------
798 -- 9.5.2 Entry Declaration --
799 ------------------------------
801 -- ENTRY_DECLARATION ::=
802 -- [OVERRIDING_INDICATOR]
803 -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)]
804 -- PARAMETER_PROFILE;
805 -- [ASPECT_SPECIFICATIONS];
807 -- The caller has checked that the initial token is ENTRY, NOT or
810 -- Error recovery: cannot raise Error_Resync
812 function P_Entry_Declaration return Node_Id is
814 Scan_State : Saved_Scan_State;
816 -- Flags for optional overriding indication. Two flags are needed,
817 -- to distinguish positive and negative overriding indicators from
818 -- the absence of any indicator.
820 Is_Overriding : Boolean := False;
821 Not_Overriding : Boolean := False;
824 -- Ada 2005 (AI-397): Scan leading overriding indicator
826 if Token = Tok_Not then
829 if Token = Tok_Overriding then
830 Scan; -- part OVERRIDING
831 Not_Overriding := True;
833 Error_Msg_SC -- CODEFIX
834 ("OVERRIDING expected!");
837 elsif Token = Tok_Overriding then
838 Scan; -- part OVERRIDING
839 Is_Overriding := True;
842 if Is_Overriding or else Not_Overriding then
843 if Ada_Version < Ada_2005 then
844 Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
845 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
847 elsif Token /= Tok_Entry then
848 Error_Msg_SC -- CODEFIX
853 Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
856 Set_Defining_Identifier
857 (Decl_Node, P_Defining_Identifier (C_Left_Paren_Semicolon));
859 -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
861 if Token = Tok_Left_Paren then
864 -- If identifier after left paren, could still be either
866 if Token = Tok_Identifier then
867 Save_Scan_State (Scan_State); -- at Id
870 -- If comma or colon after Id, must be Formal_Part
872 if Token = Tok_Comma or else Token = Tok_Colon then
873 Restore_Scan_State (Scan_State); -- to Id
874 Set_Parameter_Specifications (Decl_Node, P_Formal_Part);
876 -- Else if Id without comma or colon, must be discrete subtype
880 Restore_Scan_State (Scan_State); -- to Id
881 Set_Discrete_Subtype_Definition
882 (Decl_Node, P_Discrete_Subtype_Definition);
884 Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
887 -- If no Id, must be discrete subtype definition
890 Set_Discrete_Subtype_Definition
891 (Decl_Node, P_Discrete_Subtype_Definition);
893 Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
897 if Is_Overriding then
898 Set_Must_Override (Decl_Node);
899 elsif Not_Overriding then
900 Set_Must_Not_Override (Decl_Node);
903 -- Error recovery check for illegal return
905 if Token = Tok_Return then
906 Error_Msg_SC ("entry cannot have return value!");
908 Discard_Junk_Node (P_Subtype_Indication);
911 -- Error recovery check for improper use of entry barrier in spec
913 if Token = Tok_When then
914 Error_Msg_SC ("barrier not allowed here (belongs in body)");
916 Discard_Junk_Node (P_Expression_No_Right_Paren);
919 P_Aspect_Specifications (Decl_Node);
924 Resync_Past_Semicolon;
926 end P_Entry_Declaration;
928 -----------------------------
929 -- 9.5.2 Accept Statement --
930 -----------------------------
932 -- ACCEPT_STATEMENT ::=
933 -- accept entry_DIRECT_NAME
934 -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do
935 -- HANDLED_SEQUENCE_OF_STATEMENTS
936 -- end [entry_IDENTIFIER]];
938 -- The caller has checked that the initial token is ACCEPT
940 -- Error recovery: cannot raise Error_Resync. If an error occurs, the
941 -- scan is resynchronized past the next semicolon and control returns.
943 function P_Accept_Statement return Node_Id is
944 Scan_State : Saved_Scan_State;
945 Accept_Node : Node_Id;
950 Scope.Table (Scope.Last).Sloc := Token_Ptr;
951 Scope.Table (Scope.Last).Ecol := Start_Column;
953 Accept_Node := New_Node (N_Accept_Statement, Token_Ptr);
955 Scope.Table (Scope.Last).Labl := Token_Node;
957 Set_Entry_Direct_Name (Accept_Node, P_Identifier (C_Do));
959 -- Left paren could be (Entry_Index) or Formal_Part, determine which
961 if Token = Tok_Left_Paren then
962 Save_Scan_State (Scan_State); -- at left paren
963 Scan; -- past left paren
965 -- If first token after left paren not identifier, then Entry_Index
967 if Token /= Tok_Identifier then
968 Set_Entry_Index (Accept_Node, P_Expression);
970 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
972 -- First token after left paren is identifier, could be either case
974 else -- Token = Tok_Identifier
975 Scan; -- past identifier
977 -- If identifier followed by comma or colon, must be Formal_Part
979 if Token = Tok_Comma or else Token = Tok_Colon then
980 Restore_Scan_State (Scan_State); -- to left paren
981 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
983 -- If identifier not followed by comma/colon, must be entry index
986 Restore_Scan_State (Scan_State); -- to left paren
987 Scan; -- past left paren (again!)
988 Set_Entry_Index (Accept_Node, P_Expression);
990 Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
995 -- Scan out DO if present
997 if Token = Tok_Do then
998 Scope.Table (Scope.Last).Etyp := E_Name;
999 Scope.Table (Scope.Last).Lreq := False;
1001 Hand_Seq := P_Handled_Sequence_Of_Statements;
1002 Set_Handled_Statement_Sequence (Accept_Node, Hand_Seq);
1003 End_Statements (Handled_Statement_Sequence (Accept_Node));
1005 -- Exception handlers not allowed in Ada 95 node
1007 if Present (Exception_Handlers (Hand_Seq)) then
1008 if Ada_Version = Ada_83 then
1010 ("(Ada 83) exception handlers in accept not allowed",
1011 First_Non_Pragma (Exception_Handlers (Hand_Seq)));
1016 Pop_Scope_Stack; -- discard unused entry
1022 -- If error, resynchronize past semicolon
1025 when Error_Resync =>
1026 Resync_Past_Semicolon;
1027 Pop_Scope_Stack; -- discard unused entry
1030 end P_Accept_Statement;
1032 ------------------------
1033 -- 9.5.2 Entry Index --
1034 ------------------------
1036 -- Parsed by P_Expression (4.4)
1038 -----------------------
1039 -- 9.5.2 Entry Body --
1040 -----------------------
1043 -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is
1046 -- HANDLED_SEQUENCE_OF_STATEMENTS
1047 -- end [entry_IDENTIFIER];
1049 -- The caller has checked that the initial token is ENTRY
1051 -- Error_Recovery: cannot raise Error_Resync
1053 function P_Entry_Body return Node_Id is
1054 Entry_Node : Node_Id;
1055 Formal_Part_Node : Node_Id;
1056 Name_Node : Node_Id;
1060 Entry_Node := New_Node (N_Entry_Body, Token_Ptr);
1063 Scope.Table (Scope.Last).Ecol := Start_Column;
1064 Scope.Table (Scope.Last).Lreq := False;
1065 Scope.Table (Scope.Last).Etyp := E_Name;
1066 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1068 Name_Node := P_Defining_Identifier;
1069 Set_Defining_Identifier (Entry_Node, Name_Node);
1070 Scope.Table (Scope.Last).Labl := Name_Node;
1072 Formal_Part_Node := P_Entry_Body_Formal_Part;
1073 Set_Entry_Body_Formal_Part (Entry_Node, Formal_Part_Node);
1075 Set_Condition (Formal_Part_Node, P_Entry_Barrier);
1076 Parse_Decls_Begin_End (Entry_Node);
1080 -----------------------------------
1081 -- 9.5.2 Entry Body Formal Part --
1082 -----------------------------------
1084 -- ENTRY_BODY_FORMAL_PART ::=
1085 -- [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART]
1087 -- Error_Recovery: cannot raise Error_Resync
1089 function P_Entry_Body_Formal_Part return Node_Id is
1090 Fpart_Node : Node_Id;
1091 Scan_State : Saved_Scan_State;
1094 Fpart_Node := New_Node (N_Entry_Body_Formal_Part, Token_Ptr);
1096 -- See if entry index specification present, and if so parse it
1098 if Token = Tok_Left_Paren then
1099 Save_Scan_State (Scan_State); -- at left paren
1100 Scan; -- past left paren
1102 if Token = Tok_For then
1103 Set_Entry_Index_Specification
1104 (Fpart_Node, P_Entry_Index_Specification);
1107 Restore_Scan_State (Scan_State); -- to left paren
1110 -- Check for (common?) case of left paren omitted before FOR. This
1111 -- is a tricky case, because the corresponding missing left paren
1112 -- can cause real havoc if a formal part is present which gets
1113 -- treated as part of the discrete subtype definition of the
1114 -- entry index specification, so just give error and resynchronize
1116 elsif Token = Tok_For then
1117 T_Left_Paren; -- to give error message
1121 Set_Parameter_Specifications (Fpart_Node, P_Parameter_Profile);
1123 end P_Entry_Body_Formal_Part;
1125 --------------------------
1126 -- 9.5.2 Entry Barrier --
1127 --------------------------
1129 -- ENTRY_BARRIER ::= when CONDITION
1131 -- Error_Recovery: cannot raise Error_Resync
1133 function P_Entry_Barrier return Node_Id is
1137 if Token = Tok_When then
1139 Bnode := P_Expression_No_Right_Paren;
1141 if Token = Tok_Colon_Equal then
1142 Error_Msg_SC -- CODEFIX
1143 ("|"":="" should be ""=""");
1145 Bnode := P_Expression_No_Right_Paren;
1149 T_When; -- to give error message
1155 end P_Entry_Barrier;
1157 --------------------------------------
1158 -- 9.5.2 Entry Index Specification --
1159 --------------------------------------
1161 -- ENTRY_INDEX_SPECIFICATION ::=
1162 -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
1164 -- Error recovery: can raise Error_Resync
1166 function P_Entry_Index_Specification return Node_Id is
1167 Iterator_Node : Node_Id;
1170 Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr);
1172 Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier (C_In));
1174 Set_Discrete_Subtype_Definition
1175 (Iterator_Node, P_Discrete_Subtype_Definition);
1176 return Iterator_Node;
1177 end P_Entry_Index_Specification;
1179 ---------------------------------
1180 -- 9.5.3 Entry Call Statement --
1181 ---------------------------------
1183 -- Parsed by P_Name (4.1). Within a select, an entry call is parsed
1184 -- by P_Select_Statement (9.7)
1186 ------------------------------
1187 -- 9.5.4 Requeue Statement --
1188 ------------------------------
1190 -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort];
1192 -- The caller has checked that the initial token is requeue
1194 -- Error recovery: can raise Error_Resync
1196 function P_Requeue_Statement return Node_Id is
1197 Requeue_Node : Node_Id;
1200 Requeue_Node := New_Node (N_Requeue_Statement, Token_Ptr);
1201 Scan; -- past REQUEUE
1202 Set_Name (Requeue_Node, P_Name);
1204 if Token = Tok_With then
1207 Set_Abort_Present (Requeue_Node, True);
1211 return Requeue_Node;
1212 end P_Requeue_Statement;
1214 --------------------------
1215 -- 9.6 Delay Statement --
1216 --------------------------
1218 -- DELAY_STATEMENT ::=
1219 -- DELAY_UNTIL_STATEMENT
1220 -- | DELAY_RELATIVE_STATEMENT
1222 -- The caller has checked that the initial token is DELAY
1224 -- Error recovery: cannot raise Error_Resync
1226 function P_Delay_Statement return Node_Id is
1230 -- The following check for delay until misused in Ada 83 doesn't catch
1231 -- all cases, but it's good enough to catch most of them!
1233 if Token_Name = Name_Until then
1234 Check_95_Keyword (Tok_Until, Tok_Left_Paren);
1235 Check_95_Keyword (Tok_Until, Tok_Identifier);
1238 if Token = Tok_Until then
1239 return P_Delay_Until_Statement;
1241 return P_Delay_Relative_Statement;
1243 end P_Delay_Statement;
1245 --------------------------------
1246 -- 9.6 Delay Until Statement --
1247 --------------------------------
1249 -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION;
1251 -- The caller has checked that the initial token is DELAY, scanned it
1252 -- out and checked that the current token is UNTIL
1254 -- Error recovery: cannot raise Error_Resync
1256 function P_Delay_Until_Statement return Node_Id is
1257 Delay_Node : Node_Id;
1260 Delay_Node := New_Node (N_Delay_Until_Statement, Prev_Token_Ptr);
1262 Set_Expression (Delay_Node, P_Expression_No_Right_Paren);
1265 end P_Delay_Until_Statement;
1267 -----------------------------------
1268 -- 9.6 Delay Relative Statement --
1269 -----------------------------------
1271 -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION;
1273 -- The caller has checked that the initial token is DELAY, scanned it
1274 -- out and determined that the current token is not UNTIL
1276 -- Error recovery: cannot raise Error_Resync
1278 function P_Delay_Relative_Statement return Node_Id is
1279 Delay_Node : Node_Id;
1282 Delay_Node := New_Node (N_Delay_Relative_Statement, Prev_Token_Ptr);
1283 Set_Expression (Delay_Node, P_Expression_No_Right_Paren);
1284 Check_Simple_Expression_In_Ada_83 (Expression (Delay_Node));
1287 end P_Delay_Relative_Statement;
1289 ---------------------------
1290 -- 9.7 Select Statement --
1291 ---------------------------
1293 -- SELECT_STATEMENT ::=
1295 -- | TIMED_ENTRY_CALL
1296 -- | CONDITIONAL_ENTRY_CALL
1297 -- | ASYNCHRONOUS_SELECT
1299 -- SELECTIVE_ACCEPT ::=
1302 -- SELECT_ALTERNATIVE
1305 -- SELECT_ALTERNATIVE
1307 -- SEQUENCE_OF_STATEMENTS]
1310 -- GUARD ::= when CONDITION =>
1312 -- Note: the guard preceding a select alternative is included as part
1313 -- of the node generated for a selective accept alternative.
1315 -- SELECT_ALTERNATIVE ::=
1316 -- ACCEPT_ALTERNATIVE
1317 -- | DELAY_ALTERNATIVE
1318 -- | TERMINATE_ALTERNATIVE
1320 -- TIMED_ENTRY_CALL ::=
1322 -- ENTRY_CALL_ALTERNATIVE
1324 -- DELAY_ALTERNATIVE
1327 -- CONDITIONAL_ENTRY_CALL ::=
1329 -- ENTRY_CALL_ALTERNATIVE
1331 -- SEQUENCE_OF_STATEMENTS
1334 -- ENTRY_CALL_ALTERNATIVE ::=
1335 -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS]
1337 -- ASYNCHRONOUS_SELECT ::=
1339 -- TRIGGERING_ALTERNATIVE
1344 -- TRIGGERING_ALTERNATIVE ::=
1345 -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS]
1347 -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT
1349 -- The caller has checked that the initial token is SELECT
1351 -- Error recovery: can raise Error_Resync
1353 function P_Select_Statement return Node_Id is
1354 Select_Node : Node_Id;
1355 Select_Sloc : Source_Ptr;
1356 Stmnt_Sloc : Source_Ptr;
1357 Ecall_Node : Node_Id;
1358 Alternative : Node_Id;
1359 Select_Pragmas : List_Id;
1360 Alt_Pragmas : List_Id;
1361 Statement_List : List_Id;
1363 Cond_Expr : Node_Id;
1364 Delay_Stmnt : Node_Id;
1368 Scope.Table (Scope.Last).Etyp := E_Select;
1369 Scope.Table (Scope.Last).Ecol := Start_Column;
1370 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1371 Scope.Table (Scope.Last).Labl := Error;
1373 Select_Sloc := Token_Ptr;
1374 Scan; -- past SELECT
1375 Stmnt_Sloc := Token_Ptr;
1376 Select_Pragmas := P_Pragmas_Opt;
1378 -- If first token after select is designator, then we have an entry
1379 -- call, which must be the start of a conditional entry call, timed
1380 -- entry call or asynchronous select
1382 if Token in Token_Class_Desig then
1384 -- Scan entry call statement
1387 Ecall_Node := P_Name;
1389 -- ?? The following two clauses exactly parallel code in ch5
1390 -- and should be combined sometime
1392 if Nkind (Ecall_Node) = N_Indexed_Component then
1394 Prefix_Node : constant Node_Id := Prefix (Ecall_Node);
1395 Exprs_Node : constant List_Id := Expressions (Ecall_Node);
1398 Change_Node (Ecall_Node, N_Procedure_Call_Statement);
1399 Set_Name (Ecall_Node, Prefix_Node);
1400 Set_Parameter_Associations (Ecall_Node, Exprs_Node);
1403 elsif Nkind (Ecall_Node) = N_Function_Call then
1405 Fname_Node : constant Node_Id := Name (Ecall_Node);
1406 Params_List : constant List_Id :=
1407 Parameter_Associations (Ecall_Node);
1410 Change_Node (Ecall_Node, N_Procedure_Call_Statement);
1411 Set_Name (Ecall_Node, Fname_Node);
1412 Set_Parameter_Associations (Ecall_Node, Params_List);
1415 elsif Nkind (Ecall_Node) = N_Identifier
1416 or else Nkind (Ecall_Node) = N_Selected_Component
1418 -- Case of a call to a parameterless entry
1421 C_Node : constant Node_Id :=
1422 New_Node (N_Procedure_Call_Statement, Stmnt_Sloc);
1424 Set_Name (C_Node, Ecall_Node);
1425 Set_Parameter_Associations (C_Node, No_List);
1426 Ecall_Node := C_Node;
1433 when Error_Resync =>
1434 Resync_Past_Semicolon;
1438 Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
1440 -- OR follows, we have a timed entry call
1442 if Token = Tok_Or then
1444 Alt_Pragmas := P_Pragmas_Opt;
1446 Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc);
1447 Set_Entry_Call_Alternative (Select_Node,
1448 Make_Entry_Call_Alternative (Stmnt_Sloc,
1449 Entry_Call_Statement => Ecall_Node,
1450 Pragmas_Before => Select_Pragmas,
1451 Statements => Statement_List));
1453 -- Only possibility is delay alternative. If we have anything
1454 -- else, give message, and treat as conditional entry call.
1456 if Token /= Tok_Delay then
1458 ("only allowed alternative in timed entry call is delay!");
1459 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1460 Set_Delay_Alternative (Select_Node, Error);
1463 Set_Delay_Alternative (Select_Node, P_Delay_Alternative);
1465 (Delay_Alternative (Select_Node), Alt_Pragmas);
1468 -- ELSE follows, we have a conditional entry call
1470 elsif Token = Tok_Else then
1472 Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc);
1474 Set_Entry_Call_Alternative (Select_Node,
1475 Make_Entry_Call_Alternative (Stmnt_Sloc,
1476 Entry_Call_Statement => Ecall_Node,
1477 Pragmas_Before => Select_Pragmas,
1478 Statements => Statement_List));
1481 (Select_Node, P_Sequence_Of_Statements (SS_Sreq));
1483 -- Only remaining case is THEN ABORT (asynchronous select)
1485 elsif Token = Tok_Abort then
1487 Make_Asynchronous_Select (Select_Sloc,
1488 Triggering_Alternative =>
1489 Make_Triggering_Alternative (Stmnt_Sloc,
1490 Triggering_Statement => Ecall_Node,
1491 Pragmas_Before => Select_Pragmas,
1492 Statements => Statement_List),
1493 Abortable_Part => P_Abortable_Part);
1498 if Ada_Version = Ada_83 then
1499 Error_Msg_BC ("OR or ELSE expected");
1501 Error_Msg_BC ("OR or ELSE or THEN ABORT expected");
1504 Select_Node := Error;
1509 -- Here we have a selective accept or an asynchronous select (first
1510 -- token after SELECT is other than a designator token).
1513 -- If we have delay with no guard, could be asynchronous select
1515 if Token = Tok_Delay then
1516 Delay_Stmnt := P_Delay_Statement;
1517 Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
1519 -- Asynchronous select
1521 if Token = Tok_Abort then
1523 Make_Asynchronous_Select (Select_Sloc,
1524 Triggering_Alternative =>
1525 Make_Triggering_Alternative (Stmnt_Sloc,
1526 Triggering_Statement => Delay_Stmnt,
1527 Pragmas_Before => Select_Pragmas,
1528 Statements => Statement_List),
1529 Abortable_Part => P_Abortable_Part);
1534 -- Delay which was not an asynchronous select. Must be a selective
1535 -- accept, and since at least one accept statement is required,
1536 -- we must have at least one OR phrase present.
1539 Alt_List := New_List (
1540 Make_Delay_Alternative (Stmnt_Sloc,
1541 Delay_Statement => Delay_Stmnt,
1542 Pragmas_Before => Select_Pragmas,
1543 Statements => Statement_List));
1545 Alt_Pragmas := P_Pragmas_Opt;
1548 -- If not a delay statement, then must be another possibility for
1549 -- a selective accept alternative, or perhaps a guard is present
1552 Alt_List := New_List;
1553 Alt_Pragmas := Select_Pragmas;
1556 Select_Node := New_Node (N_Selective_Accept, Select_Sloc);
1557 Set_Select_Alternatives (Select_Node, Alt_List);
1559 -- Scan out selective accept alternatives. On entry to this loop,
1560 -- we are just past a SELECT or OR token, and any pragmas that
1561 -- immediately follow the SELECT or OR are in Alt_Pragmas.
1564 if Token = Tok_When then
1566 if Present (Alt_Pragmas) then
1567 Error_Msg_SC ("pragmas may not precede guard");
1571 Cond_Expr := P_Expression_No_Right_Paren;
1573 Alt_Pragmas := P_Pragmas_Opt;
1579 if Token = Tok_Accept then
1580 Alternative := P_Accept_Alternative;
1582 -- Check for junk attempt at asynchronous select using
1583 -- an Accept alternative as the triggering statement
1585 if Token = Tok_Abort
1586 and then Is_Empty_List (Alt_List)
1587 and then No (Cond_Expr)
1590 ("triggering statement must be entry call or delay",
1591 Sloc (Alternative));
1592 Scan; -- past junk ABORT
1593 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1598 elsif Token = Tok_Delay then
1599 Alternative := P_Delay_Alternative;
1601 elsif Token = Tok_Terminate then
1602 Alternative := P_Terminate_Alternative;
1606 ("select alternative (ACCEPT, ABORT, DELAY) expected");
1607 Alternative := Error;
1609 if Token = Tok_Semicolon then
1610 Scan; -- past junk semicolon
1614 -- THEN ABORT at this stage is just junk
1616 if Token = Tok_Abort then
1617 Error_Msg_SP ("misplaced `THEN ABORT`");
1618 Scan; -- past junk ABORT
1619 Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
1624 if Alternative /= Error then
1625 Set_Condition (Alternative, Cond_Expr);
1626 Set_Pragmas_Before (Alternative, Alt_Pragmas);
1627 Append (Alternative, Alt_List);
1630 exit when Token /= Tok_Or;
1634 Alt_Pragmas := P_Pragmas_Opt;
1637 if Token = Tok_Else then
1640 (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq));
1642 if Token = Tok_Or then
1643 Error_Msg_SC ("select alternative cannot follow else part!");
1651 end P_Select_Statement;
1653 -----------------------------
1654 -- 9.7.1 Selective Accept --
1655 -----------------------------
1657 -- Parsed by P_Select_Statement (9.7)
1663 -- Parsed by P_Select_Statement (9.7)
1665 -------------------------------
1666 -- 9.7.1 Select Alternative --
1667 -------------------------------
1669 -- SELECT_ALTERNATIVE ::=
1670 -- ACCEPT_ALTERNATIVE
1671 -- | DELAY_ALTERNATIVE
1672 -- | TERMINATE_ALTERNATIVE
1674 -- Note: the guard preceding a select alternative is included as part
1675 -- of the node generated for a selective accept alternative.
1677 -- Error recovery: cannot raise Error_Resync
1679 -------------------------------
1680 -- 9.7.1 Accept Alternative --
1681 -------------------------------
1683 -- ACCEPT_ALTERNATIVE ::=
1684 -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
1686 -- Error_Recovery: Cannot raise Error_Resync
1688 -- Note: the caller is responsible for setting the Pragmas_Before
1689 -- field of the returned N_Terminate_Alternative node.
1691 function P_Accept_Alternative return Node_Id is
1692 Accept_Alt_Node : Node_Id;
1695 Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr);
1696 Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement);
1698 -- Note: the reason that we accept THEN ABORT as a terminator for
1699 -- the sequence of statements is for error recovery which allows
1700 -- for misuse of an accept statement as a triggering statement.
1703 (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
1704 return Accept_Alt_Node;
1705 end P_Accept_Alternative;
1707 ------------------------------
1708 -- 9.7.1 Delay Alternative --
1709 ------------------------------
1711 -- DELAY_ALTERNATIVE ::=
1712 -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
1714 -- Error_Recovery: Cannot raise Error_Resync
1716 -- Note: the caller is responsible for setting the Pragmas_Before
1717 -- field of the returned N_Terminate_Alternative node.
1719 function P_Delay_Alternative return Node_Id is
1720 Delay_Alt_Node : Node_Id;
1723 Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr);
1724 Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement);
1726 -- Note: the reason that we accept THEN ABORT as a terminator for
1727 -- the sequence of statements is for error recovery which allows
1728 -- for misuse of an accept statement as a triggering statement.
1731 (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
1732 return Delay_Alt_Node;
1733 end P_Delay_Alternative;
1735 ----------------------------------
1736 -- 9.7.1 Terminate Alternative --
1737 ----------------------------------
1739 -- TERMINATE_ALTERNATIVE ::= terminate;
1741 -- Error_Recovery: Cannot raise Error_Resync
1743 -- Note: the caller is responsible for setting the Pragmas_Before
1744 -- field of the returned N_Terminate_Alternative node.
1746 function P_Terminate_Alternative return Node_Id is
1747 Terminate_Alt_Node : Node_Id;
1750 Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr);
1751 Scan; -- past TERMINATE
1754 -- For all other select alternatives, the sequence of statements
1755 -- after the alternative statement will swallow up any pragmas
1756 -- coming in this position. But the terminate alternative has no
1757 -- sequence of statements, so the pragmas here must be treated
1760 Set_Pragmas_After (Terminate_Alt_Node, P_Pragmas_Opt);
1761 return Terminate_Alt_Node;
1762 end P_Terminate_Alternative;
1764 -----------------------------
1765 -- 9.7.2 Timed Entry Call --
1766 -----------------------------
1768 -- Parsed by P_Select_Statement (9.7)
1770 -----------------------------------
1771 -- 9.7.2 Entry Call Alternative --
1772 -----------------------------------
1774 -- Parsed by P_Select_Statement (9.7)
1776 -----------------------------------
1777 -- 9.7.3 Conditional Entry Call --
1778 -----------------------------------
1780 -- Parsed by P_Select_Statement (9.7)
1782 --------------------------------
1783 -- 9.7.4 Asynchronous Select --
1784 --------------------------------
1786 -- Parsed by P_Select_Statement (9.7)
1788 -----------------------------------
1789 -- 9.7.4 Triggering Alternative --
1790 -----------------------------------
1792 -- Parsed by P_Select_Statement (9.7)
1794 ---------------------------------
1795 -- 9.7.4 Triggering Statement --
1796 ---------------------------------
1798 -- Parsed by P_Select_Statement (9.7)
1800 ---------------------------
1801 -- 9.7.4 Abortable Part --
1802 ---------------------------
1804 -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
1806 -- The caller has verified that THEN ABORT is present, and Token is
1807 -- pointing to the ABORT on entry (or if not, then we have an error)
1809 -- Error recovery: cannot raise Error_Resync
1811 function P_Abortable_Part return Node_Id is
1812 Abortable_Part_Node : Node_Id;
1815 Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr);
1816 T_Abort; -- scan past ABORT
1818 if Ada_Version = Ada_83 then
1819 Error_Msg_SP ("(Ada 83) asynchronous select not allowed!");
1822 Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq));
1823 return Abortable_Part_Node;
1824 end P_Abortable_Part;
1826 --------------------------
1827 -- 9.8 Abort Statement --
1828 --------------------------
1830 -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
1832 -- The caller has checked that the initial token is ABORT
1834 -- Error recovery: cannot raise Error_Resync
1836 function P_Abort_Statement return Node_Id is
1837 Abort_Node : Node_Id;
1840 Abort_Node := New_Node (N_Abort_Statement, Token_Ptr);
1842 Set_Names (Abort_Node, New_List);
1845 Append (P_Name, Names (Abort_Node));
1846 exit when Token /= Tok_Comma;
1852 end P_Abort_Statement;