1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 [ASPECT_SPECIFICATIONS] is
67 -- HANDLED_SEQUENCE_OF_STATEMENTS
68 -- end [task_IDENTIFIER]
71 -- task body DEFINING_IDENTIFIER is separate
72 -- [ASPECT_SPECIFICATIONS];
74 -- This routine scans out a task declaration, task body, or task stub
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
79 -- Error recovery: cannot raise Error_Resync
81 function P_Task
return Node_Id
is
82 Aspect_Sloc
: Source_Ptr
:= No_Location
;
85 Task_Sloc
: Source_Ptr
;
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.
94 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
95 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
96 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
97 Scope
.Table
(Scope
.Last
).Lreq
:= False;
98 Task_Sloc
:= Prev_Token_Ptr
;
100 if Token
= Tok_Body
then
102 Name_Node
:= P_Defining_Identifier
(C_Is
);
103 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
104 Current_Node
:= Name_Node
;
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
);
111 if Aspect_Specifications_Present
then
112 Aspect_Sloc
:= Token_Ptr
;
113 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> False);
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
);
125 if Has_Aspects
(Dummy_Node
) then
127 ("aspect specifications must come after SEPARATE",
131 P_Aspect_Specifications
(Task_Node
, Semicolon
=> False);
133 Pop_Scope_Stack
; -- remove unused entry
138 Task_Node
:= New_Node
(N_Task_Body
, Task_Sloc
);
139 Set_Defining_Identifier
(Task_Node
, Name_Node
);
141 -- Move the aspect specifications to the body node
143 if Has_Aspects
(Dummy_Node
) then
144 Move_Aspects
(From
=> Dummy_Node
, To
=> Task_Node
);
147 Parse_Decls_Begin_End
(Task_Node
);
149 -- The statement list of a task body needs to include at least a
150 -- null statement, so if a parsing error produces an empty list,
153 if No
(First
(Statements
154 (Handled_Statement_Sequence
(Task_Node
))))
156 Set_Statements
(Handled_Statement_Sequence
(Task_Node
),
157 New_List
(Make_Null_Statement
(Token_Ptr
)));
163 -- Otherwise we must have a task declaration
166 if Token
= Tok_Type
then
168 Task_Node
:= New_Node
(N_Task_Type_Declaration
, Task_Sloc
);
169 Name_Node
:= P_Defining_Identifier
;
170 Set_Defining_Identifier
(Task_Node
, Name_Node
);
171 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
172 Current_Node
:= Name_Node
;
173 Set_Discriminant_Specifications
174 (Task_Node
, P_Known_Discriminant_Part_Opt
);
177 Task_Node
:= New_Node
(N_Single_Task_Declaration
, Task_Sloc
);
178 Name_Node
:= P_Defining_Identifier
(C_Is
);
179 Set_Defining_Identifier
(Task_Node
, Name_Node
);
180 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
181 Current_Node
:= Name_Node
;
183 if Token
= Tok_Left_Paren
then
184 Error_Msg_SC
("discriminant part not allowed for single task");
185 Discard_Junk_List
(P_Known_Discriminant_Part_Opt
);
189 -- Scan aspect specifications, don't eat the semicolon, since it
190 -- might not be there if we have an IS.
192 P_Aspect_Specifications
(Task_Node
, Semicolon
=> False);
194 -- Parse optional task definition. Note that P_Task_Definition scans
195 -- out the semicolon and possible aspect specifications as well as
196 -- the task definition itself.
198 if Token
= Tok_Semicolon
then
200 -- A little check, if the next token after semicolon is Entry,
201 -- then surely the semicolon should really be IS
203 Scan
; -- past semicolon
205 if Token
= Tok_Entry
then
206 Error_Msg_SP
-- CODEFIX
207 ("|"";"" should be IS");
208 Set_Task_Definition
(Task_Node
, P_Task_Definition
);
210 Pop_Scope_Stack
; -- Remove unused entry
213 -- Here we have a task definition
216 TF_Is
; -- must have IS if no semicolon
220 if Token
= Tok_New
then
223 if Ada_Version
< Ada_2005
then
224 Error_Msg_SP
("task interface is an Ada 2005 extension");
225 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
228 Set_Interface_List
(Task_Node
, New_List
);
231 Append
(P_Qualified_Simple_Name
, Interface_List
(Task_Node
));
232 exit when Token
/= Tok_And
;
236 if Token
/= Tok_With
then
237 Error_Msg_SC
-- CODEFIX
243 if Token
= Tok_Private
then
244 Error_Msg_SP
-- CODEFIX
245 ("PRIVATE not allowed in task type declaration");
249 Set_Task_Definition
(Task_Node
, P_Task_Definition
);
256 --------------------------------
257 -- 9.1 Task Type Declaration --
258 --------------------------------
260 -- Parsed by P_Task (9.1)
262 ----------------------------------
263 -- 9.1 Single Task Declaration --
264 ----------------------------------
266 -- Parsed by P_Task (9.1)
268 --------------------------
269 -- 9.1 Task Definition --
270 --------------------------
272 -- TASK_DEFINITION ::=
276 -- end [task_IDENTIFIER];
278 -- The caller has already made the scope stack entry
280 -- Note: there is a small deviation from official syntax here in that we
281 -- regard the semicolon after end as part of the Task_Definition, and in
282 -- the official syntax, it's part of the enclosing declaration. The reason
283 -- for this deviation is that otherwise the end processing would have to
284 -- be special cased, which would be a nuisance.
286 -- Error recovery: cannot raise Error_Resync
288 function P_Task_Definition
return Node_Id
is
292 Def_Node
:= New_Node
(N_Task_Definition
, Token_Ptr
);
293 Set_Visible_Declarations
(Def_Node
, P_Task_Items
);
295 if Token
= Tok_Private
then
296 Scan
; -- past PRIVATE
297 Set_Private_Declarations
(Def_Node
, P_Task_Items
);
299 -- Deal gracefully with multiple PRIVATE parts
301 while Token
= Tok_Private
loop
302 Error_Msg_SC
("only one private part allowed per task");
303 Scan
; -- past PRIVATE
304 Append_List
(P_Task_Items
, Private_Declarations
(Def_Node
));
308 End_Statements
(Def_Node
);
310 end P_Task_Definition
;
316 -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE
318 -- This subprogram scans a (possibly empty) list of task items and pragmas
320 -- Error recovery: cannot raise Error_Resync
322 -- Note: a pragma can also be returned in this position
324 function P_Task_Items
return List_Id
is
327 Decl_Sloc
: Source_Ptr
;
330 -- Get rid of active SIS entry from outer scope. This means we will
331 -- miss some nested cases, but it doesn't seem worth the effort. See
332 -- discussion in Par for further details
334 SIS_Entry_Active
:= False;
336 -- Loop to scan out task items
341 Decl_Sloc
:= Token_Ptr
;
343 if Token
= Tok_Pragma
then
344 P_Pragmas_Opt
(Items
);
346 -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING may begin an
347 -- entry declaration.
349 elsif Token
= Tok_Entry
350 or else Token
= Tok_Not
351 or else Token
= Tok_Overriding
353 Append
(P_Entry_Declaration
, Items
);
355 elsif Token
= Tok_For
then
357 -- Representation clause in task declaration. The only rep clause
358 -- which is legal in a protected declaration is an address clause,
359 -- so that is what we try to scan out.
361 Item_Node
:= P_Representation_Clause
;
363 if Nkind
(Item_Node
) = N_At_Clause
then
364 Append
(Item_Node
, Items
);
366 elsif Nkind
(Item_Node
) = N_Attribute_Definition_Clause
367 and then Chars
(Item_Node
) = Name_Address
369 Append
(Item_Node
, Items
);
373 ("the only representation clause " &
374 "allowed here is an address clause!", Decl_Sloc
);
377 elsif Token
= Tok_Identifier
378 or else Token
in Token_Class_Declk
380 Error_Msg_SC
("illegal declaration in task definition");
381 Resync_Past_Semicolon
;
395 -- Parsed by P_Task (9.1)
397 ----------------------------------
398 -- 9.4 Protected (also 10.1.3) --
399 ----------------------------------
401 -- PROTECTED_TYPE_DECLARATION ::=
402 -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
403 -- [ASPECT_SPECIFICATIONS]
404 -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
406 -- SINGLE_PROTECTED_DECLARATION ::=
407 -- protected DEFINING_IDENTIFIER
408 -- [ASPECT_SPECIFICATIONS]
409 -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
411 -- PROTECTED_BODY ::=
412 -- protected body DEFINING_IDENTIFIER
413 -- [ASPECT_SPECIFICATIONS]
415 -- {PROTECTED_OPERATION_ITEM}
416 -- end [protected_IDENTIFIER];
418 -- PROTECTED_BODY_STUB ::=
419 -- protected body DEFINING_IDENTIFIER is separate
420 -- [ASPECT_SPECIFICATIONS];
422 -- This routine scans out a protected declaration, protected body
423 -- or a protected stub.
425 -- The caller has checked that the initial token is PROTECTED and
426 -- scanned past it, so Token is set to the following token.
428 -- Error recovery: cannot raise Error_Resync
430 function P_Protected
return Node_Id
is
431 Aspect_Sloc
: Source_Ptr
:= No_Location
;
433 Protected_Node
: Node_Id
;
434 Protected_Sloc
: Source_Ptr
;
435 Scan_State
: Saved_Scan_State
;
437 Dummy_Node
: constant Node_Id
:= New_Node
(N_Protected_Body
, Token_Ptr
);
438 -- Placeholder node used to hold legal or prematurely declared aspect
439 -- specifications. Depending on the context, the aspect specifications
440 -- may be moved to a new node.
444 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
445 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
446 Scope
.Table
(Scope
.Last
).Lreq
:= False;
447 Protected_Sloc
:= Prev_Token_Ptr
;
449 if Token
= Tok_Body
then
451 Name_Node
:= P_Defining_Identifier
(C_Is
);
452 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
453 Current_Node
:= Name_Node
;
455 if Token
= Tok_Left_Paren
then
456 Error_Msg_SC
("discriminant part not allowed in protected body");
457 Discard_Junk_List
(P_Known_Discriminant_Part_Opt
);
460 if Aspect_Specifications_Present
then
461 Aspect_Sloc
:= Token_Ptr
;
462 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> False);
469 if Token
= Tok_Separate
then
470 Scan
; -- past SEPARATE
472 Protected_Node
:= New_Node
(N_Protected_Body_Stub
, Protected_Sloc
);
473 Set_Defining_Identifier
(Protected_Node
, Name_Node
);
475 if Has_Aspects
(Dummy_Node
) then
477 ("aspect specifications must come after SEPARATE",
481 P_Aspect_Specifications
(Protected_Node
, Semicolon
=> False);
483 Pop_Scope_Stack
; -- remove unused entry
488 Protected_Node
:= New_Node
(N_Protected_Body
, Protected_Sloc
);
489 Set_Defining_Identifier
(Protected_Node
, Name_Node
);
491 Move_Aspects
(From
=> Dummy_Node
, To
=> Protected_Node
);
492 Set_Declarations
(Protected_Node
, P_Protected_Operation_Items
);
493 End_Statements
(Protected_Node
);
496 return Protected_Node
;
498 -- Otherwise we must have a protected declaration
501 if Token
= Tok_Type
then
504 New_Node
(N_Protected_Type_Declaration
, Protected_Sloc
);
505 Name_Node
:= P_Defining_Identifier
(C_Is
);
506 Set_Defining_Identifier
(Protected_Node
, Name_Node
);
507 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
508 Current_Node
:= Name_Node
;
509 Set_Discriminant_Specifications
510 (Protected_Node
, P_Known_Discriminant_Part_Opt
);
514 New_Node
(N_Single_Protected_Declaration
, Protected_Sloc
);
515 Name_Node
:= P_Defining_Identifier
(C_Is
);
516 Set_Defining_Identifier
(Protected_Node
, Name_Node
);
518 if Token
= Tok_Left_Paren
then
520 ("discriminant part not allowed for single protected");
521 Discard_Junk_List
(P_Known_Discriminant_Part_Opt
);
524 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
525 Current_Node
:= Name_Node
;
528 P_Aspect_Specifications
(Protected_Node
, Semicolon
=> False);
530 -- Check for semicolon not followed by IS, this is something like
536 -- protected type r IS END;
538 if Token
= Tok_Semicolon
then
539 Save_Scan_State
(Scan_State
); -- at semicolon
540 Scan
; -- past semicolon
542 if Token
/= Tok_Is
then
543 Restore_Scan_State
(Scan_State
);
544 Error_Msg_SC
-- CODEFIX
546 Set_Protected_Definition
(Protected_Node
,
547 Make_Protected_Definition
(Token_Ptr
,
548 Visible_Declarations
=> Empty_List
,
549 End_Label
=> Empty
));
551 SIS_Entry_Active
:= False;
553 (Protected_Definition
(Protected_Node
), Protected_Node
);
554 return Protected_Node
;
557 Error_Msg_SP
-- CODEFIX
558 ("|extra ""("" ignored");
565 if Token
= Tok_New
then
568 if Ada_Version
< Ada_2005
then
569 Error_Msg_SP
("protected interface is an Ada 2005 extension");
570 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
573 Set_Interface_List
(Protected_Node
, New_List
);
576 Append
(P_Qualified_Simple_Name
,
577 Interface_List
(Protected_Node
));
579 exit when Token
/= Tok_And
;
583 if Token
/= Tok_With
then
584 Error_Msg_SC
-- CODEFIX
591 Set_Protected_Definition
(Protected_Node
, P_Protected_Definition
);
592 return Protected_Node
;
596 -------------------------------------
597 -- 9.4 Protected Type Declaration --
598 -------------------------------------
600 -- Parsed by P_Protected (9.4)
602 ---------------------------------------
603 -- 9.4 Single Protected Declaration --
604 ---------------------------------------
606 -- Parsed by P_Protected (9.4)
608 -------------------------------
609 -- 9.4 Protected Definition --
610 -------------------------------
612 -- PROTECTED_DEFINITION ::=
613 -- {PROTECTED_OPERATION_DECLARATION}
615 -- {PROTECTED_ELEMENT_DECLARATION}]
616 -- end [protected_IDENTIFIER]
618 -- PROTECTED_ELEMENT_DECLARATION ::=
619 -- PROTECTED_OPERATION_DECLARATION
620 -- | COMPONENT_DECLARATION
622 -- The caller has already established the scope stack entry
624 -- Error recovery: cannot raise Error_Resync
626 function P_Protected_Definition
return Node_Id
is
629 Priv_Decls
: List_Id
;
633 Def_Node
:= New_Node
(N_Protected_Definition
, Token_Ptr
);
635 -- Get rid of active SIS entry from outer scope. This means we will
636 -- miss some nested cases, but it doesn't seem worth the effort. See
637 -- discussion in Par for further details
639 SIS_Entry_Active
:= False;
641 -- Loop to scan visible declarations (protected operation declarations)
643 Vis_Decls
:= New_List
;
644 Set_Visible_Declarations
(Def_Node
, Vis_Decls
);
646 -- Flag and discard all pragmas which cannot appear in the protected
647 -- definition. Note that certain pragmas are still allowed as long as
648 -- they apply to entries, entry families, or protected subprograms.
650 P_Pragmas_Opt
(Vis_Decls
);
653 Item_Node
:= P_Protected_Operation_Declaration_Opt
;
655 if Present
(Item_Node
) then
656 Append
(Item_Node
, Vis_Decls
);
659 P_Pragmas_Opt
(Vis_Decls
);
661 exit when No
(Item_Node
);
664 -- Deal with PRIVATE part (including graceful handling of multiple
667 Private_Loop
: while Token
= Tok_Private
loop
668 Priv_Decls
:= Private_Declarations
(Def_Node
);
670 if Present
(Priv_Decls
) then
671 Error_Msg_SC
("duplicate private part");
673 Priv_Decls
:= New_List
;
674 Set_Private_Declarations
(Def_Node
, Priv_Decls
);
677 Scan
; -- past PRIVATE
679 -- Flag and discard all pragmas which cannot appear in the protected
680 -- definition. Note that certain pragmas are still allowed as long as
681 -- they apply to entries, entry families, or protected subprograms.
683 P_Pragmas_Opt
(Priv_Decls
);
685 Declaration_Loop
: loop
686 if Token
= Tok_Identifier
then
687 P_Component_Items
(Priv_Decls
);
688 P_Pragmas_Opt
(Priv_Decls
);
691 Item_Node
:= P_Protected_Operation_Declaration_Opt
;
693 if Present
(Item_Node
) then
694 Append
(Item_Node
, Priv_Decls
);
697 P_Pragmas_Opt
(Priv_Decls
);
699 exit Declaration_Loop
when No
(Item_Node
);
701 end loop Declaration_Loop
;
702 end loop Private_Loop
;
704 End_Statements
(Def_Node
);
706 end P_Protected_Definition
;
708 ------------------------------------------
709 -- 9.4 Protected Operation Declaration --
710 ------------------------------------------
712 -- PROTECTED_OPERATION_DECLARATION ::=
713 -- SUBPROGRAM_DECLARATION
714 -- | ENTRY_DECLARATION
715 -- | REPRESENTATION_CLAUSE
717 -- Error recovery: cannot raise Error_Resync
719 -- Note: a pragma can also be returned in this position
721 -- We are not currently permitting representation clauses to appear as
722 -- protected operation declarations, do we have to rethink this???
724 function P_Protected_Operation_Declaration_Opt
return Node_Id
is
728 function P_Entry_Or_Subprogram_With_Indicator
return Node_Id
;
729 -- Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding
730 -- indicator. The caller has checked that the initial token is NOT or
733 ------------------------------------------
734 -- P_Entry_Or_Subprogram_With_Indicator --
735 ------------------------------------------
737 function P_Entry_Or_Subprogram_With_Indicator
return Node_Id
is
738 Decl
: Node_Id
:= Error
;
739 Is_Overriding
: Boolean := False;
740 Not_Overriding
: Boolean := False;
743 if Token
= Tok_Not
then
746 if Token
= Tok_Overriding
then
747 Scan
; -- past OVERRIDING
748 Not_Overriding
:= True;
750 Error_Msg_SC
-- CODEFIX
751 ("OVERRIDING expected!");
755 Scan
; -- past OVERRIDING
756 Is_Overriding
:= True;
759 if Is_Overriding
or else Not_Overriding
then
760 if Ada_Version
< Ada_2005
then
761 Error_Msg_SP
("overriding indicator is an Ada 2005 extension");
762 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
764 elsif Token
= Tok_Entry
then
765 Decl
:= P_Entry_Declaration
;
767 Set_Must_Override
(Decl
, Is_Overriding
);
768 Set_Must_Not_Override
(Decl
, Not_Overriding
);
770 elsif Token
= Tok_Function
or else Token
= Tok_Procedure
then
771 Decl
:= P_Subprogram
(Pf_Decl_Pexp
);
773 Set_Must_Override
(Specification
(Decl
), Is_Overriding
);
774 Set_Must_Not_Override
(Specification
(Decl
), Not_Overriding
);
777 Error_Msg_SC
-- CODEFIX
778 ("ENTRY, FUNCTION or PROCEDURE expected!");
783 end P_Entry_Or_Subprogram_With_Indicator
;
785 -- Start of processing for P_Protected_Operation_Declaration_Opt
788 -- This loop runs more than once only when a junk declaration
792 if Token
= Tok_Pragma
then
795 elsif Token
= Tok_Not
or else Token
= Tok_Overriding
then
796 return P_Entry_Or_Subprogram_With_Indicator
;
798 elsif Token
= Tok_Entry
then
799 return P_Entry_Declaration
;
801 elsif Token
= Tok_Function
or else Token
= Tok_Procedure
then
802 return P_Subprogram
(Pf_Decl_Pexp
);
804 elsif Token
= Tok_Identifier
then
807 Skip_Declaration
(L
);
809 if Nkind
(First
(L
)) = N_Object_Declaration
then
811 ("component must be declared in private part of " &
812 "protected type", P
);
815 ("illegal declaration in protected definition", P
);
818 elsif Token
in Token_Class_Declk
then
819 Error_Msg_SC
("illegal declaration in protected definition");
820 Resync_Past_Semicolon
;
822 -- Return now to avoid cascaded messages if next declaration
823 -- is a valid component declaration.
827 elsif Token
= Tok_For
then
829 ("representation clause not allowed in protected definition");
830 Resync_Past_Semicolon
;
836 end P_Protected_Operation_Declaration_Opt
;
838 -----------------------------------
839 -- 9.4 Protected Operation Item --
840 -----------------------------------
842 -- PROTECTED_OPERATION_ITEM ::=
843 -- SUBPROGRAM_DECLARATION
846 -- | REPRESENTATION_CLAUSE
848 -- This procedure parses and returns a list of protected operation items
850 -- We are not currently permitting representation clauses to appear
851 -- as protected operation items, do we have to rethink this???
853 function P_Protected_Operation_Items
return List_Id
is
857 Item_List
:= New_List
;
860 if Token
= Tok_Entry
or else Bad_Spelling_Of
(Tok_Entry
) then
861 Append
(P_Entry_Body
, Item_List
);
863 -- If the operation starts with procedure, function, or an overriding
864 -- indicator ("overriding" or "not overriding"), parse a subprogram.
866 elsif Token
= Tok_Function
or else Bad_Spelling_Of
(Tok_Function
)
868 Token
= Tok_Procedure
or else Bad_Spelling_Of
(Tok_Procedure
)
870 Token
= Tok_Overriding
or else Bad_Spelling_Of
(Tok_Overriding
)
872 Token
= Tok_Not
or else Bad_Spelling_Of
(Tok_Not
)
874 Append
(P_Subprogram
(Pf_Decl_Pbod_Pexp
), Item_List
);
876 elsif Token
= Tok_Pragma
or else Bad_Spelling_Of
(Tok_Pragma
) then
877 P_Pragmas_Opt
(Item_List
);
879 elsif Token
= Tok_Private
or else Bad_Spelling_Of
(Tok_Private
) then
880 Error_Msg_SC
("PRIVATE not allowed in protected body");
881 Scan
; -- past PRIVATE
883 elsif Token
= Tok_Identifier
then
884 Error_Msg_SC
("all components must be declared in spec!");
885 Resync_Past_Semicolon
;
887 elsif Token
in Token_Class_Declk
then
888 Error_Msg_SC
("this declaration not allowed in protected body");
889 Resync_Past_Semicolon
;
897 end P_Protected_Operation_Items
;
899 ------------------------------
900 -- 9.5.2 Entry Declaration --
901 ------------------------------
903 -- ENTRY_DECLARATION ::=
904 -- [OVERRIDING_INDICATOR]
905 -- entry DEFINING_IDENTIFIER
906 -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE
907 -- [ASPECT_SPECIFICATIONS];
909 -- The caller has checked that the initial token is ENTRY, NOT or
912 -- Error recovery: cannot raise Error_Resync
914 function P_Entry_Declaration
return Node_Id
is
916 Scan_State
: Saved_Scan_State
;
918 -- Flags for optional overriding indication. Two flags are needed,
919 -- to distinguish positive and negative overriding indicators from
920 -- the absence of any indicator.
922 Is_Overriding
: Boolean := False;
923 Not_Overriding
: Boolean := False;
926 -- Ada 2005 (AI-397): Scan leading overriding indicator
928 if Token
= Tok_Not
then
931 if Token
= Tok_Overriding
then
932 Scan
; -- part OVERRIDING
933 Not_Overriding
:= True;
935 Error_Msg_SC
-- CODEFIX
936 ("OVERRIDING expected!");
939 elsif Token
= Tok_Overriding
then
940 Scan
; -- part OVERRIDING
941 Is_Overriding
:= True;
944 if Is_Overriding
or else Not_Overriding
then
945 if Ada_Version
< Ada_2005
then
946 Error_Msg_SP
("overriding indicator is an Ada 2005 extension");
947 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
949 elsif Token
/= Tok_Entry
then
950 Error_Msg_SC
-- CODEFIX
955 Decl_Node
:= New_Node
(N_Entry_Declaration
, Token_Ptr
);
958 Set_Defining_Identifier
959 (Decl_Node
, P_Defining_Identifier
(C_Left_Paren_Semicolon
));
961 -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
963 if Token
= Tok_Left_Paren
then
966 -- If identifier after left paren, could still be either
968 if Token
= Tok_Identifier
then
969 Save_Scan_State
(Scan_State
); -- at Id
972 -- If comma or colon after Id, must be Formal_Part
974 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
975 Restore_Scan_State
(Scan_State
); -- to Id
976 Set_Parameter_Specifications
(Decl_Node
, P_Formal_Part
);
978 -- Else if Id without comma or colon, must be discrete subtype
982 Restore_Scan_State
(Scan_State
); -- to Id
983 Set_Discrete_Subtype_Definition
984 (Decl_Node
, P_Discrete_Subtype_Definition
);
986 Set_Parameter_Specifications
(Decl_Node
, P_Parameter_Profile
);
989 -- If no Id, must be discrete subtype definition
992 Set_Discrete_Subtype_Definition
993 (Decl_Node
, P_Discrete_Subtype_Definition
);
995 Set_Parameter_Specifications
(Decl_Node
, P_Parameter_Profile
);
999 if Is_Overriding
then
1000 Set_Must_Override
(Decl_Node
);
1001 elsif Not_Overriding
then
1002 Set_Must_Not_Override
(Decl_Node
);
1005 -- Error recovery check for illegal return
1007 if Token
= Tok_Return
then
1008 Error_Msg_SC
("entry cannot have return value!");
1010 Discard_Junk_Node
(P_Subtype_Indication
);
1013 -- Error recovery check for improper use of entry barrier in spec
1015 if Token
= Tok_When
then
1016 Error_Msg_SC
("barrier not allowed here (belongs in body)");
1018 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
1021 P_Aspect_Specifications
(Decl_Node
);
1025 when Error_Resync
=>
1026 Resync_Past_Semicolon
;
1028 end P_Entry_Declaration
;
1030 -----------------------------
1031 -- 9.5.2 Accept Statement --
1032 -----------------------------
1034 -- ACCEPT_STATEMENT ::=
1035 -- accept entry_DIRECT_NAME
1036 -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do
1037 -- HANDLED_SEQUENCE_OF_STATEMENTS
1038 -- end [entry_IDENTIFIER]];
1040 -- The caller has checked that the initial token is ACCEPT
1042 -- Error recovery: cannot raise Error_Resync. If an error occurs, the
1043 -- scan is resynchronized past the next semicolon and control returns.
1045 function P_Accept_Statement
return Node_Id
is
1046 Scan_State
: Saved_Scan_State
;
1047 Accept_Node
: Node_Id
;
1052 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1053 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1055 Accept_Node
:= New_Node
(N_Accept_Statement
, Token_Ptr
);
1056 Scan
; -- past ACCEPT
1057 Scope
.Table
(Scope
.Last
).Labl
:= Token_Node
;
1058 Current_Node
:= Token_Node
;
1060 Set_Entry_Direct_Name
(Accept_Node
, P_Identifier
(C_Do
));
1062 -- Left paren could be (Entry_Index) or Formal_Part, determine which
1064 if Token
= Tok_Left_Paren
then
1065 Save_Scan_State
(Scan_State
); -- at left paren
1066 Scan
; -- past left paren
1068 -- If first token after left paren not identifier, then Entry_Index
1070 if Token
/= Tok_Identifier
then
1071 Set_Entry_Index
(Accept_Node
, P_Expression
);
1073 Set_Parameter_Specifications
(Accept_Node
, P_Parameter_Profile
);
1075 -- First token after left paren is identifier, could be either case
1077 else -- Token = Tok_Identifier
1078 Scan
; -- past identifier
1080 -- If identifier followed by comma or colon, must be Formal_Part
1082 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
1083 Restore_Scan_State
(Scan_State
); -- to left paren
1084 Set_Parameter_Specifications
(Accept_Node
, P_Parameter_Profile
);
1086 -- If identifier not followed by comma/colon, must be entry index
1089 Restore_Scan_State
(Scan_State
); -- to left paren
1090 Scan
; -- past left paren (again)
1091 Set_Entry_Index
(Accept_Node
, P_Expression
);
1093 Set_Parameter_Specifications
(Accept_Node
, P_Parameter_Profile
);
1098 -- Scan out DO if present
1100 if Token
= Tok_Do
then
1101 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
1102 Scope
.Table
(Scope
.Last
).Lreq
:= False;
1104 Hand_Seq
:= P_Handled_Sequence_Of_Statements
;
1105 Set_Handled_Statement_Sequence
(Accept_Node
, Hand_Seq
);
1106 End_Statements
(Handled_Statement_Sequence
(Accept_Node
));
1108 -- Exception handlers not allowed in Ada 95 node
1110 if Present
(Exception_Handlers
(Hand_Seq
)) then
1111 if Ada_Version
= Ada_83
then
1113 ("(Ada 83) exception handlers in accept not allowed",
1114 First_Non_Pragma
(Exception_Handlers
(Hand_Seq
)));
1119 Pop_Scope_Stack
; -- discard unused entry
1125 -- If error, resynchronize past semicolon
1128 when Error_Resync
=>
1129 Resync_Past_Semicolon
;
1130 Pop_Scope_Stack
; -- discard unused entry
1132 end P_Accept_Statement
;
1134 ------------------------
1135 -- 9.5.2 Entry Index --
1136 ------------------------
1138 -- Parsed by P_Expression (4.4)
1140 --------------------------
1141 -- 9.5.2 Entry Barrier --
1142 --------------------------
1144 -- ENTRY_BARRIER ::= when CONDITION
1146 -- Error_Recovery: cannot raise Error_Resync
1148 function P_Entry_Barrier
return Node_Id
is
1152 if Token
= Tok_When
then
1154 Bnode
:= P_Expression_No_Right_Paren
;
1156 if Token
= Tok_Colon_Equal
then
1157 Error_Msg_SC
-- CODEFIX
1158 ("|"":="" should be ""=""");
1160 Bnode
:= P_Expression_No_Right_Paren
;
1164 T_When
; -- to give error message
1169 end P_Entry_Barrier
;
1171 -----------------------
1172 -- 9.5.2 Entry Body --
1173 -----------------------
1176 -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART
1177 -- [ASPECT_SPECIFICATIONS] ENTRY_BARRIER
1181 -- HANDLED_SEQUENCE_OF_STATEMENTS
1182 -- end [entry_IDENTIFIER];
1184 -- The caller has checked that the initial token is ENTRY
1186 -- Error_Recovery: cannot raise Error_Resync
1188 function P_Entry_Body
return Node_Id
is
1189 Dummy_Node
: Node_Id
;
1190 Entry_Node
: Node_Id
;
1191 Formal_Part_Node
: Node_Id
;
1192 Name_Node
: Node_Id
;
1196 Entry_Node
:= New_Node
(N_Entry_Body
, Token_Ptr
);
1199 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1200 Scope
.Table
(Scope
.Last
).Lreq
:= False;
1201 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
1202 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1204 Name_Node
:= P_Defining_Identifier
;
1205 Set_Defining_Identifier
(Entry_Node
, Name_Node
);
1206 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
1207 Current_Node
:= Name_Node
;
1209 Formal_Part_Node
:= P_Entry_Body_Formal_Part
;
1210 Set_Entry_Body_Formal_Part
(Entry_Node
, Formal_Part_Node
);
1212 -- Ada 2012 (AI12-0169): Aspect specifications may appear on an entry
1213 -- body immediately after the formal part. Do not parse the aspect
1214 -- specifications directly because the "when" of the entry barrier may
1215 -- be interpreted as a misused "with".
1217 if Token
= Tok_With
then
1218 P_Aspect_Specifications
(Entry_Node
, Semicolon
=> False);
1221 Set_Condition
(Formal_Part_Node
, P_Entry_Barrier
);
1223 -- Detect an illegal placement of aspect specifications following the
1226 -- entry E ... when Barrier with Aspect is
1228 if Token
= Tok_With
then
1229 Error_Msg_SC
("aspect specifications must come before entry barrier");
1231 -- Consume the illegal aspects to allow for parsing to continue
1233 Dummy_Node
:= New_Node
(N_Entry_Body
, Sloc
(Entry_Node
));
1234 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> False);
1238 Parse_Decls_Begin_End
(Entry_Node
);
1243 -----------------------------------
1244 -- 9.5.2 Entry Body Formal Part --
1245 -----------------------------------
1247 -- ENTRY_BODY_FORMAL_PART ::=
1248 -- [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART]
1250 -- Error_Recovery: cannot raise Error_Resync
1252 function P_Entry_Body_Formal_Part
return Node_Id
is
1253 Fpart_Node
: Node_Id
;
1254 Scan_State
: Saved_Scan_State
;
1257 Fpart_Node
:= New_Node
(N_Entry_Body_Formal_Part
, Token_Ptr
);
1259 -- See if entry index specification present, and if so parse it
1261 if Token
= Tok_Left_Paren
then
1262 Save_Scan_State
(Scan_State
); -- at left paren
1263 Scan
; -- past left paren
1265 if Token
= Tok_For
then
1266 Set_Entry_Index_Specification
1267 (Fpart_Node
, P_Entry_Index_Specification
);
1270 Restore_Scan_State
(Scan_State
); -- to left paren
1273 -- Check for (common?) case of left paren omitted before FOR. This
1274 -- is a tricky case, because the corresponding missing left paren
1275 -- can cause real havoc if a formal part is present which gets
1276 -- treated as part of the discrete subtype definition of the
1277 -- entry index specification, so just give error and resynchronize
1279 elsif Token
= Tok_For
then
1280 T_Left_Paren
; -- to give error message
1284 Set_Parameter_Specifications
(Fpart_Node
, P_Parameter_Profile
);
1286 end P_Entry_Body_Formal_Part
;
1288 --------------------------------------
1289 -- 9.5.2 Entry Index Specification --
1290 --------------------------------------
1292 -- ENTRY_INDEX_SPECIFICATION ::=
1293 -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
1295 -- Error recovery: can raise Error_Resync
1297 function P_Entry_Index_Specification
return Node_Id
is
1298 Iterator_Node
: Node_Id
;
1301 Iterator_Node
:= New_Node
(N_Entry_Index_Specification
, Token_Ptr
);
1303 Set_Defining_Identifier
(Iterator_Node
, P_Defining_Identifier
(C_In
));
1305 Set_Discrete_Subtype_Definition
1306 (Iterator_Node
, P_Discrete_Subtype_Definition
);
1307 return Iterator_Node
;
1308 end P_Entry_Index_Specification
;
1310 ---------------------------------
1311 -- 9.5.3 Entry Call Statement --
1312 ---------------------------------
1314 -- Parsed by P_Name (4.1). Within a select, an entry call is parsed
1315 -- by P_Select_Statement (9.7)
1317 ------------------------------
1318 -- 9.5.4 Requeue Statement --
1319 ------------------------------
1321 -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort];
1323 -- The caller has checked that the initial token is requeue
1325 -- Error recovery: can raise Error_Resync
1327 function P_Requeue_Statement
return Node_Id
is
1328 Requeue_Node
: Node_Id
;
1331 Requeue_Node
:= New_Node
(N_Requeue_Statement
, Token_Ptr
);
1332 Scan
; -- past REQUEUE
1333 Set_Name
(Requeue_Node
, P_Name
);
1335 if Token
= Tok_With
then
1338 Set_Abort_Present
(Requeue_Node
, True);
1342 return Requeue_Node
;
1343 end P_Requeue_Statement
;
1345 --------------------------
1346 -- 9.6 Delay Statement --
1347 --------------------------
1349 -- DELAY_STATEMENT ::=
1350 -- DELAY_UNTIL_STATEMENT
1351 -- | DELAY_RELATIVE_STATEMENT
1353 -- The caller has checked that the initial token is DELAY
1355 -- Error recovery: cannot raise Error_Resync
1357 function P_Delay_Statement
return Node_Id
is
1361 -- The following check for delay until misused in Ada 83 doesn't catch
1362 -- all cases, but it's good enough to catch most of them.
1364 if Token_Name
= Name_Until
then
1365 Check_95_Keyword
(Tok_Until
, Tok_Left_Paren
);
1366 Check_95_Keyword
(Tok_Until
, Tok_Identifier
);
1369 if Token
= Tok_Until
then
1370 return P_Delay_Until_Statement
;
1372 return P_Delay_Relative_Statement
;
1374 end P_Delay_Statement
;
1376 --------------------------------
1377 -- 9.6 Delay Until Statement --
1378 --------------------------------
1380 -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION;
1382 -- The caller has checked that the initial token is DELAY, scanned it
1383 -- out and checked that the current token is UNTIL
1385 -- Error recovery: cannot raise Error_Resync
1387 function P_Delay_Until_Statement
return Node_Id
is
1388 Delay_Node
: Node_Id
;
1391 Delay_Node
:= New_Node
(N_Delay_Until_Statement
, Prev_Token_Ptr
);
1393 Set_Expression
(Delay_Node
, P_Expression_No_Right_Paren
);
1396 end P_Delay_Until_Statement
;
1398 -----------------------------------
1399 -- 9.6 Delay Relative Statement --
1400 -----------------------------------
1402 -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION;
1404 -- The caller has checked that the initial token is DELAY, scanned it
1405 -- out and determined that the current token is not UNTIL
1407 -- Error recovery: cannot raise Error_Resync
1409 function P_Delay_Relative_Statement
return Node_Id
is
1410 Delay_Node
: Node_Id
;
1413 Delay_Node
:= New_Node
(N_Delay_Relative_Statement
, Prev_Token_Ptr
);
1414 Set_Expression
(Delay_Node
, P_Expression_No_Right_Paren
);
1415 Check_Simple_Expression_In_Ada_83
(Expression
(Delay_Node
));
1418 end P_Delay_Relative_Statement
;
1420 ---------------------------
1421 -- 9.7 Select Statement --
1422 ---------------------------
1424 -- SELECT_STATEMENT ::=
1426 -- | TIMED_ENTRY_CALL
1427 -- | CONDITIONAL_ENTRY_CALL
1428 -- | ASYNCHRONOUS_SELECT
1430 -- SELECTIVE_ACCEPT ::=
1433 -- SELECT_ALTERNATIVE
1436 -- SELECT_ALTERNATIVE
1438 -- SEQUENCE_OF_STATEMENTS]
1441 -- GUARD ::= when CONDITION =>
1443 -- Note: the guard preceding a select alternative is included as part
1444 -- of the node generated for a selective accept alternative.
1446 -- SELECT_ALTERNATIVE ::=
1447 -- ACCEPT_ALTERNATIVE
1448 -- | DELAY_ALTERNATIVE
1449 -- | TERMINATE_ALTERNATIVE
1451 -- TIMED_ENTRY_CALL ::=
1453 -- ENTRY_CALL_ALTERNATIVE
1455 -- DELAY_ALTERNATIVE
1458 -- CONDITIONAL_ENTRY_CALL ::=
1460 -- ENTRY_CALL_ALTERNATIVE
1462 -- SEQUENCE_OF_STATEMENTS
1465 -- ENTRY_CALL_ALTERNATIVE ::=
1466 -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS]
1468 -- ASYNCHRONOUS_SELECT ::=
1470 -- TRIGGERING_ALTERNATIVE
1475 -- TRIGGERING_ALTERNATIVE ::=
1476 -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS]
1478 -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT
1480 -- The caller has checked that the initial token is SELECT
1482 -- Error recovery: can raise Error_Resync
1484 function P_Select_Statement
return Node_Id
is
1485 Select_Node
: Node_Id
;
1486 Select_Sloc
: Source_Ptr
;
1487 Stmnt_Sloc
: Source_Ptr
;
1488 Ecall_Node
: Node_Id
;
1489 Alternative
: Node_Id
;
1490 Select_Pragmas
: List_Id
;
1491 Alt_Pragmas
: List_Id
;
1492 Statement_List
: List_Id
;
1494 Cond_Expr
: Node_Id
;
1495 Delay_Stmnt
: Node_Id
;
1499 Scope
.Table
(Scope
.Last
).Etyp
:= E_Select
;
1500 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1501 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1502 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
1504 Select_Sloc
:= Token_Ptr
;
1505 Scan
; -- past SELECT
1506 Stmnt_Sloc
:= Token_Ptr
;
1507 Select_Pragmas
:= P_Pragmas_Opt
;
1509 -- If first token after select is designator, then we have an entry
1510 -- call, which must be the start of a conditional entry call, timed
1511 -- entry call or asynchronous select
1513 if Token
in Token_Class_Desig
then
1515 -- Scan entry call statement
1518 Ecall_Node
:= P_Name
;
1520 -- ?? The following two clauses exactly parallel code in ch5
1521 -- and should be combined sometime
1523 if Nkind
(Ecall_Node
) = N_Indexed_Component
then
1525 Prefix_Node
: constant Node_Id
:= Prefix
(Ecall_Node
);
1526 Exprs_Node
: constant List_Id
:= Expressions
(Ecall_Node
);
1529 Change_Node
(Ecall_Node
, N_Procedure_Call_Statement
);
1530 Set_Name
(Ecall_Node
, Prefix_Node
);
1531 Set_Parameter_Associations
(Ecall_Node
, Exprs_Node
);
1534 elsif Nkind
(Ecall_Node
) = N_Function_Call
then
1536 Fname_Node
: constant Node_Id
:= Name
(Ecall_Node
);
1537 Params_List
: constant List_Id
:=
1538 Parameter_Associations
(Ecall_Node
);
1541 Change_Node
(Ecall_Node
, N_Procedure_Call_Statement
);
1542 Set_Name
(Ecall_Node
, Fname_Node
);
1543 Set_Parameter_Associations
(Ecall_Node
, Params_List
);
1546 elsif Nkind
(Ecall_Node
) = N_Identifier
1547 or else Nkind
(Ecall_Node
) = N_Selected_Component
1549 -- Case of a call to a parameterless entry
1552 C_Node
: constant Node_Id
:=
1553 New_Node
(N_Procedure_Call_Statement
, Stmnt_Sloc
);
1555 Set_Name
(C_Node
, Ecall_Node
);
1556 Set_Parameter_Associations
(C_Node
, No_List
);
1557 Ecall_Node
:= C_Node
;
1564 when Error_Resync
=>
1565 Resync_Past_Semicolon
;
1569 Statement_List
:= P_Sequence_Of_Statements
(SS_Eltm_Ortm_Tatm
);
1571 -- OR follows, we have a timed entry call
1573 if Token
= Tok_Or
then
1575 Alt_Pragmas
:= P_Pragmas_Opt
;
1577 Select_Node
:= New_Node
(N_Timed_Entry_Call
, Select_Sloc
);
1578 Set_Entry_Call_Alternative
(Select_Node
,
1579 Make_Entry_Call_Alternative
(Stmnt_Sloc
,
1580 Entry_Call_Statement
=> Ecall_Node
,
1581 Pragmas_Before
=> Select_Pragmas
,
1582 Statements
=> Statement_List
));
1584 -- Only possibility is delay alternative. If we have anything
1585 -- else, give message, and treat as conditional entry call.
1587 if Token
/= Tok_Delay
then
1589 ("only allowed alternative in timed entry call is delay!");
1590 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Sreq
));
1591 Set_Delay_Alternative
(Select_Node
, Error
);
1594 Set_Delay_Alternative
(Select_Node
, P_Delay_Alternative
);
1596 (Delay_Alternative
(Select_Node
), Alt_Pragmas
);
1599 -- ELSE follows, we have a conditional entry call
1601 elsif Token
= Tok_Else
then
1603 Select_Node
:= New_Node
(N_Conditional_Entry_Call
, Select_Sloc
);
1605 Set_Entry_Call_Alternative
(Select_Node
,
1606 Make_Entry_Call_Alternative
(Stmnt_Sloc
,
1607 Entry_Call_Statement
=> Ecall_Node
,
1608 Pragmas_Before
=> Select_Pragmas
,
1609 Statements
=> Statement_List
));
1612 (Select_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1614 -- Only remaining case is THEN ABORT (asynchronous select)
1616 elsif Token
= Tok_Abort
then
1618 Make_Asynchronous_Select
(Select_Sloc
,
1619 Triggering_Alternative
=>
1620 Make_Triggering_Alternative
(Stmnt_Sloc
,
1621 Triggering_Statement
=> Ecall_Node
,
1622 Pragmas_Before
=> Select_Pragmas
,
1623 Statements
=> Statement_List
),
1624 Abortable_Part
=> P_Abortable_Part
);
1629 if Ada_Version
= Ada_83
then
1630 Error_Msg_BC
("OR or ELSE expected");
1632 Error_Msg_BC
("OR or ELSE or THEN ABORT expected");
1635 Select_Node
:= Error
;
1640 -- Here we have a selective accept or an asynchronous select (first
1641 -- token after SELECT is other than a designator token).
1644 -- If we have delay with no guard, could be asynchronous select
1646 if Token
= Tok_Delay
then
1647 Delay_Stmnt
:= P_Delay_Statement
;
1648 Statement_List
:= P_Sequence_Of_Statements
(SS_Eltm_Ortm_Tatm
);
1650 -- Asynchronous select
1652 if Token
= Tok_Abort
then
1654 Make_Asynchronous_Select
(Select_Sloc
,
1655 Triggering_Alternative
=>
1656 Make_Triggering_Alternative
(Stmnt_Sloc
,
1657 Triggering_Statement
=> Delay_Stmnt
,
1658 Pragmas_Before
=> Select_Pragmas
,
1659 Statements
=> Statement_List
),
1660 Abortable_Part
=> P_Abortable_Part
);
1665 -- Delay which was not an asynchronous select. Must be a selective
1666 -- accept, and since at least one accept statement is required,
1667 -- we must have at least one OR phrase present.
1670 Alt_List
:= New_List
(
1671 Make_Delay_Alternative
(Stmnt_Sloc
,
1672 Delay_Statement
=> Delay_Stmnt
,
1673 Pragmas_Before
=> Select_Pragmas
,
1674 Statements
=> Statement_List
));
1676 Alt_Pragmas
:= P_Pragmas_Opt
;
1679 -- If not a delay statement, then must be another possibility for
1680 -- a selective accept alternative, or perhaps a guard is present
1683 Alt_List
:= New_List
;
1684 Alt_Pragmas
:= Select_Pragmas
;
1687 Select_Node
:= New_Node
(N_Selective_Accept
, Select_Sloc
);
1688 Set_Select_Alternatives
(Select_Node
, Alt_List
);
1690 -- Scan out selective accept alternatives. On entry to this loop,
1691 -- we are just past a SELECT or OR token, and any pragmas that
1692 -- immediately follow the SELECT or OR are in Alt_Pragmas.
1695 if Token
= Tok_When
then
1697 if Present
(Alt_Pragmas
) then
1698 Error_Msg_SC
("pragmas may not precede guard");
1702 Cond_Expr
:= P_Expression_No_Right_Paren
;
1704 Alt_Pragmas
:= P_Pragmas_Opt
;
1710 if Token
= Tok_Accept
then
1711 Alternative
:= P_Accept_Alternative
;
1713 -- Check for junk attempt at asynchronous select using
1714 -- an Accept alternative as the triggering statement
1716 if Token
= Tok_Abort
1717 and then Is_Empty_List
(Alt_List
)
1718 and then No
(Cond_Expr
)
1721 ("triggering statement must be entry call or delay",
1722 Sloc
(Alternative
));
1723 Scan
; -- past junk ABORT
1724 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Sreq
));
1729 elsif Token
= Tok_Delay
then
1730 Alternative
:= P_Delay_Alternative
;
1732 elsif Token
= Tok_Terminate
then
1733 Alternative
:= P_Terminate_Alternative
;
1737 ("select alternative (ACCEPT, ABORT, DELAY) expected");
1738 Alternative
:= Error
;
1740 if Token
= Tok_Semicolon
then
1741 Scan
; -- past junk semicolon
1745 -- THEN ABORT at this stage is just junk
1747 if Token
= Tok_Abort
then
1748 Error_Msg_SP
("misplaced `THEN ABORT`");
1749 Scan
; -- past junk ABORT
1750 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Sreq
));
1755 if Alternative
/= Error
then
1756 Set_Condition
(Alternative
, Cond_Expr
);
1757 Set_Pragmas_Before
(Alternative
, Alt_Pragmas
);
1758 Append
(Alternative
, Alt_List
);
1761 exit when Token
/= Tok_Or
;
1765 Alt_Pragmas
:= P_Pragmas_Opt
;
1768 if Token
= Tok_Else
then
1771 (Select_Node
, P_Sequence_Of_Statements
(SS_Ortm_Sreq
));
1773 if Token
= Tok_Or
then
1774 Error_Msg_SC
("select alternative cannot follow else part!");
1782 end P_Select_Statement
;
1784 -----------------------------
1785 -- 9.7.1 Selective Accept --
1786 -----------------------------
1788 -- Parsed by P_Select_Statement (9.7)
1794 -- Parsed by P_Select_Statement (9.7)
1796 -------------------------------
1797 -- 9.7.1 Select Alternative --
1798 -------------------------------
1800 -- SELECT_ALTERNATIVE ::=
1801 -- ACCEPT_ALTERNATIVE
1802 -- | DELAY_ALTERNATIVE
1803 -- | TERMINATE_ALTERNATIVE
1805 -- Note: the guard preceding a select alternative is included as part
1806 -- of the node generated for a selective accept alternative.
1808 -- Error recovery: cannot raise Error_Resync
1810 -------------------------------
1811 -- 9.7.1 Accept Alternative --
1812 -------------------------------
1814 -- ACCEPT_ALTERNATIVE ::=
1815 -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
1817 -- Error_Recovery: Cannot raise Error_Resync
1819 -- Note: the caller is responsible for setting the Pragmas_Before
1820 -- field of the returned N_Terminate_Alternative node.
1822 function P_Accept_Alternative
return Node_Id
is
1823 Accept_Alt_Node
: Node_Id
;
1826 Accept_Alt_Node
:= New_Node
(N_Accept_Alternative
, Token_Ptr
);
1827 Set_Accept_Statement
(Accept_Alt_Node
, P_Accept_Statement
);
1829 -- Note: the reason that we accept THEN ABORT as a terminator for
1830 -- the sequence of statements is for error recovery which allows
1831 -- for misuse of an accept statement as a triggering statement.
1834 (Accept_Alt_Node
, P_Sequence_Of_Statements
(SS_Eltm_Ortm_Tatm
));
1835 return Accept_Alt_Node
;
1836 end P_Accept_Alternative
;
1838 ------------------------------
1839 -- 9.7.1 Delay Alternative --
1840 ------------------------------
1842 -- DELAY_ALTERNATIVE ::=
1843 -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
1845 -- Error_Recovery: Cannot raise Error_Resync
1847 -- Note: the caller is responsible for setting the Pragmas_Before
1848 -- field of the returned N_Terminate_Alternative node.
1850 function P_Delay_Alternative
return Node_Id
is
1851 Delay_Alt_Node
: Node_Id
;
1854 Delay_Alt_Node
:= New_Node
(N_Delay_Alternative
, Token_Ptr
);
1855 Set_Delay_Statement
(Delay_Alt_Node
, P_Delay_Statement
);
1857 -- Note: the reason that we accept THEN ABORT as a terminator for
1858 -- the sequence of statements is for error recovery which allows
1859 -- for misuse of an accept statement as a triggering statement.
1862 (Delay_Alt_Node
, P_Sequence_Of_Statements
(SS_Eltm_Ortm_Tatm
));
1863 return Delay_Alt_Node
;
1864 end P_Delay_Alternative
;
1866 ----------------------------------
1867 -- 9.7.1 Terminate Alternative --
1868 ----------------------------------
1870 -- TERMINATE_ALTERNATIVE ::= terminate;
1872 -- Error_Recovery: Cannot raise Error_Resync
1874 -- Note: the caller is responsible for setting the Pragmas_Before
1875 -- field of the returned N_Terminate_Alternative node.
1877 function P_Terminate_Alternative
return Node_Id
is
1878 Terminate_Alt_Node
: Node_Id
;
1881 Terminate_Alt_Node
:= New_Node
(N_Terminate_Alternative
, Token_Ptr
);
1882 Scan
; -- past TERMINATE
1885 -- For all other select alternatives, the sequence of statements
1886 -- after the alternative statement will swallow up any pragmas
1887 -- coming in this position. But the terminate alternative has no
1888 -- sequence of statements, so the pragmas here must be treated
1891 Set_Pragmas_After
(Terminate_Alt_Node
, P_Pragmas_Opt
);
1892 return Terminate_Alt_Node
;
1893 end P_Terminate_Alternative
;
1895 -----------------------------
1896 -- 9.7.2 Timed Entry Call --
1897 -----------------------------
1899 -- Parsed by P_Select_Statement (9.7)
1901 -----------------------------------
1902 -- 9.7.2 Entry Call Alternative --
1903 -----------------------------------
1905 -- Parsed by P_Select_Statement (9.7)
1907 -----------------------------------
1908 -- 9.7.3 Conditional Entry Call --
1909 -----------------------------------
1911 -- Parsed by P_Select_Statement (9.7)
1913 --------------------------------
1914 -- 9.7.4 Asynchronous Select --
1915 --------------------------------
1917 -- Parsed by P_Select_Statement (9.7)
1919 -----------------------------------
1920 -- 9.7.4 Triggering Alternative --
1921 -----------------------------------
1923 -- Parsed by P_Select_Statement (9.7)
1925 ---------------------------------
1926 -- 9.7.4 Triggering Statement --
1927 ---------------------------------
1929 -- Parsed by P_Select_Statement (9.7)
1931 ---------------------------
1932 -- 9.7.4 Abortable Part --
1933 ---------------------------
1935 -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
1937 -- The caller has verified that THEN ABORT is present, and Token is
1938 -- pointing to the ABORT on entry (or if not, then we have an error)
1940 -- Error recovery: cannot raise Error_Resync
1942 function P_Abortable_Part
return Node_Id
is
1943 Abortable_Part_Node
: Node_Id
;
1946 Abortable_Part_Node
:= New_Node
(N_Abortable_Part
, Token_Ptr
);
1947 T_Abort
; -- scan past ABORT
1949 if Ada_Version
= Ada_83
then
1950 Error_Msg_SP
("(Ada 83) asynchronous select not allowed!");
1953 Set_Statements
(Abortable_Part_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1954 return Abortable_Part_Node
;
1955 end P_Abortable_Part
;
1957 --------------------------
1958 -- 9.8 Abort Statement --
1959 --------------------------
1961 -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
1963 -- The caller has checked that the initial token is ABORT
1965 -- Error recovery: cannot raise Error_Resync
1967 function P_Abort_Statement
return Node_Id
is
1968 Abort_Node
: Node_Id
;
1971 Abort_Node
:= New_Node
(N_Abort_Statement
, Token_Ptr
);
1973 Set_Names
(Abort_Node
, New_List
);
1976 Append
(P_Name
, Names
(Abort_Node
));
1977 exit when Token
/= Tok_Comma
;
1983 end P_Abort_Statement
;