1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 pragma Style_Checks
(All_Checks
);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical
34 -- Local subprograms, used only in this chapter
36 function P_Accept_Alternative
return Node_Id
;
37 function P_Delay_Alternative
return Node_Id
;
38 function P_Delay_Relative_Statement
return Node_Id
;
39 function P_Delay_Until_Statement
return Node_Id
;
40 function P_Entry_Barrier
return Node_Id
;
41 function P_Entry_Body_Formal_Part
return Node_Id
;
42 function P_Entry_Declaration
return Node_Id
;
43 function P_Entry_Index_Specification
return Node_Id
;
44 function P_Protected_Definition
return Node_Id
;
45 function P_Protected_Operation_Declaration_Opt
return Node_Id
;
46 function P_Protected_Operation_Items
return List_Id
;
47 function P_Task_Definition
return Node_Id
;
48 function P_Task_Items
return List_Id
;
50 -----------------------------
51 -- 9.1 Task (also 10.1.3) --
52 -----------------------------
54 -- TASK_TYPE_DECLARATION ::=
55 -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
56 -- [is [new INTERFACE_LIST with] TASK_DEFINITION];
58 -- SINGLE_TASK_DECLARATION ::=
59 -- task DEFINING_IDENTIFIER
60 -- [is [new INTERFACE_LIST with] TASK_DEFINITION];
63 -- task body DEFINING_IDENTIFIER is
66 -- HANDLED_SEQUENCE_OF_STATEMENTS
67 -- end [task_IDENTIFIER]
70 -- task body DEFINING_IDENTIFIER is separate;
72 -- This routine scans out a task declaration, task body, or task stub
74 -- The caller has checked that the initial token is TASK and scanned
75 -- past it, so that Token is set to the token after TASK
77 -- Error recovery: cannot raise Error_Resync
79 function P_Task
return Node_Id
is
82 Task_Sloc
: Source_Ptr
;
86 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
87 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
88 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
89 Scope
.Table
(Scope
.Last
).Lreq
:= False;
90 Task_Sloc
:= Prev_Token_Ptr
;
92 if Token
= Tok_Body
then
94 Name_Node
:= P_Defining_Identifier
(C_Is
);
95 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
97 if Token
= Tok_Left_Paren
then
98 Error_Msg_SC
("discriminant part not allowed in task body");
99 Discard_Junk_List
(P_Known_Discriminant_Part_Opt
);
106 if Token
= Tok_Separate
then
107 Scan
; -- past SEPARATE
108 Task_Node
:= New_Node
(N_Task_Body_Stub
, Task_Sloc
);
109 Set_Defining_Identifier
(Task_Node
, Name_Node
);
111 Pop_Scope_Stack
; -- remove unused entry
116 Task_Node
:= New_Node
(N_Task_Body
, Task_Sloc
);
117 Set_Defining_Identifier
(Task_Node
, Name_Node
);
118 Parse_Decls_Begin_End
(Task_Node
);
123 -- Otherwise we must have a task declaration
126 if Token
= Tok_Type
then
128 Task_Node
:= New_Node
(N_Task_Type_Declaration
, Task_Sloc
);
129 Name_Node
:= P_Defining_Identifier
;
130 Set_Defining_Identifier
(Task_Node
, Name_Node
);
131 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
132 Set_Discriminant_Specifications
133 (Task_Node
, P_Known_Discriminant_Part_Opt
);
136 Task_Node
:= New_Node
(N_Single_Task_Declaration
, Task_Sloc
);
137 Name_Node
:= P_Defining_Identifier
(C_Is
);
138 Set_Defining_Identifier
(Task_Node
, Name_Node
);
139 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
141 if Token
= Tok_Left_Paren
then
142 Error_Msg_SC
("discriminant part not allowed for single task");
143 Discard_Junk_List
(P_Known_Discriminant_Part_Opt
);
147 -- Parse optional task definition. Note that P_Task_Definition scans
148 -- out the semicolon as well as the task definition itself.
150 if Token
= Tok_Semicolon
then
152 -- A little check, if the next token after semicolon is
153 -- Entry, then surely the semicolon should really be IS
155 Scan
; -- past semicolon
157 if Token
= Tok_Entry
then
158 Error_Msg_SP
(""";"" should be IS");
159 Set_Task_Definition
(Task_Node
, P_Task_Definition
);
161 Pop_Scope_Stack
; -- Remove unused entry
164 TF_Is
; -- must have IS if no semicolon
168 if Token
= Tok_New
then
171 if Ada_Version
< Ada_05
then
172 Error_Msg_SP
("task interface is an Ada 2005 extension");
173 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
176 Set_Interface_List
(Task_Node
, New_List
);
179 Append
(P_Qualified_Simple_Name
, Interface_List
(Task_Node
));
180 exit when Token
/= Tok_And
;
184 if Token
/= Tok_With
then
185 Error_Msg_SC
("WITH expected");
190 if Token
= Tok_Private
then
192 ("PRIVATE not allowed in task type declaration");
196 Set_Task_Definition
(Task_Node
, P_Task_Definition
);
203 --------------------------------
204 -- 9.1 Task Type Declaration --
205 --------------------------------
207 -- Parsed by P_Task (9.1)
209 ----------------------------------
210 -- 9.1 Single Task Declaration --
211 ----------------------------------
213 -- Parsed by P_Task (9.1)
215 --------------------------
216 -- 9.1 Task Definition --
217 --------------------------
219 -- TASK_DEFINITION ::=
223 -- end [task_IDENTIFIER];
225 -- The caller has already made the scope stack entry
227 -- Note: there is a small deviation from official syntax here in that we
228 -- regard the semicolon after end as part of the Task_Definition, and in
229 -- the official syntax, it's part of the enclosing declaration. The reason
230 -- for this deviation is that otherwise the end processing would have to
231 -- be special cased, which would be a nuisance!
233 -- Error recovery: cannot raise Error_Resync
235 function P_Task_Definition
return Node_Id
is
239 Def_Node
:= New_Node
(N_Task_Definition
, Token_Ptr
);
240 Set_Visible_Declarations
(Def_Node
, P_Task_Items
);
242 if Token
= Tok_Private
then
243 Scan
; -- past PRIVATE
244 Set_Private_Declarations
(Def_Node
, P_Task_Items
);
246 -- Deal gracefully with multiple PRIVATE parts
248 while Token
= Tok_Private
loop
249 Error_Msg_SC
("only one private part allowed per task");
250 Scan
; -- past PRIVATE
251 Append_List
(P_Task_Items
, Private_Declarations
(Def_Node
));
255 End_Statements
(Def_Node
);
257 end P_Task_Definition
;
263 -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE
265 -- This subprogram scans a (possibly empty) list of task items and pragmas
267 -- Error recovery: cannot raise Error_Resync
269 -- Note: a pragma can also be returned in this position
271 function P_Task_Items
return List_Id
is
274 Decl_Sloc
: Source_Ptr
;
277 -- Get rid of active SIS entry from outer scope. This means we will
278 -- miss some nested cases, but it doesn't seem worth the effort. See
279 -- discussion in Par for further details
281 SIS_Entry_Active
:= False;
283 -- Loop to scan out task items
288 Decl_Sloc
:= Token_Ptr
;
290 if Token
= Tok_Pragma
then
291 Append
(P_Pragma
, Items
);
293 -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING
294 -- may begin an entry declaration.
296 elsif Token
= Tok_Entry
297 or else Token
= Tok_Not
298 or else Token
= Tok_Overriding
300 Append
(P_Entry_Declaration
, Items
);
302 elsif Token
= Tok_For
then
303 -- Representation clause in task declaration. The only rep
304 -- clause which is legal in a protected is an address clause,
305 -- so that is what we try to scan out.
307 Item_Node
:= P_Representation_Clause
;
309 if Nkind
(Item_Node
) = N_At_Clause
then
310 Append
(Item_Node
, Items
);
312 elsif Nkind
(Item_Node
) = N_Attribute_Definition_Clause
313 and then Chars
(Item_Node
) = Name_Address
315 Append
(Item_Node
, Items
);
319 ("the only representation clause " &
320 "allowed here is an address clause!", Decl_Sloc
);
323 elsif Token
= Tok_Identifier
324 or else Token
in Token_Class_Declk
326 Error_Msg_SC
("illegal declaration in task definition");
327 Resync_Past_Semicolon
;
341 -- Parsed by P_Task (9.1)
343 ----------------------------------
344 -- 9.4 Protected (also 10.1.3) --
345 ----------------------------------
347 -- PROTECTED_TYPE_DECLARATION ::=
348 -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
349 -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
351 -- SINGLE_PROTECTED_DECLARATION ::=
352 -- protected DEFINING_IDENTIFIER
353 -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
355 -- PROTECTED_BODY ::=
356 -- protected body DEFINING_IDENTIFIER is
357 -- {PROTECTED_OPERATION_ITEM}
358 -- end [protected_IDENTIFIER];
360 -- PROTECTED_BODY_STUB ::=
361 -- protected body DEFINING_IDENTIFIER is separate;
363 -- This routine scans out a protected declaration, protected body
364 -- or a protected stub.
366 -- The caller has checked that the initial token is PROTECTED and
367 -- scanned past it, so Token is set to the following token.
369 -- Error recovery: cannot raise Error_Resync
371 function P_Protected
return Node_Id
is
373 Protected_Node
: Node_Id
;
374 Protected_Sloc
: Source_Ptr
;
378 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
379 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
380 Scope
.Table
(Scope
.Last
).Lreq
:= False;
381 Protected_Sloc
:= Prev_Token_Ptr
;
383 if Token
= Tok_Body
then
385 Name_Node
:= P_Defining_Identifier
(C_Is
);
386 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
388 if Token
= Tok_Left_Paren
then
389 Error_Msg_SC
("discriminant part not allowed in protected body");
390 Discard_Junk_List
(P_Known_Discriminant_Part_Opt
);
397 if Token
= Tok_Separate
then
398 Scan
; -- past SEPARATE
399 Protected_Node
:= New_Node
(N_Protected_Body_Stub
, Protected_Sloc
);
400 Set_Defining_Identifier
(Protected_Node
, Name_Node
);
402 Pop_Scope_Stack
; -- remove unused entry
407 Protected_Node
:= New_Node
(N_Protected_Body
, Protected_Sloc
);
408 Set_Defining_Identifier
(Protected_Node
, Name_Node
);
409 Set_Declarations
(Protected_Node
, P_Protected_Operation_Items
);
410 End_Statements
(Protected_Node
);
413 return Protected_Node
;
415 -- Otherwise we must have a protected declaration
418 if Token
= Tok_Type
then
421 New_Node
(N_Protected_Type_Declaration
, Protected_Sloc
);
422 Name_Node
:= P_Defining_Identifier
(C_Is
);
423 Set_Defining_Identifier
(Protected_Node
, Name_Node
);
424 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
425 Set_Discriminant_Specifications
426 (Protected_Node
, P_Known_Discriminant_Part_Opt
);
430 New_Node
(N_Single_Protected_Declaration
, Protected_Sloc
);
431 Name_Node
:= P_Defining_Identifier
(C_Is
);
432 Set_Defining_Identifier
(Protected_Node
, Name_Node
);
434 if Token
= Tok_Left_Paren
then
436 ("discriminant part not allowed for single protected");
437 Discard_Junk_List
(P_Known_Discriminant_Part_Opt
);
440 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
447 if Token
= Tok_New
then
450 if Ada_Version
< Ada_05
then
451 Error_Msg_SP
("task interface is an Ada 2005 extension");
452 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
455 Set_Interface_List
(Protected_Node
, New_List
);
458 Append
(P_Qualified_Simple_Name
,
459 Interface_List
(Protected_Node
));
461 exit when Token
/= Tok_And
;
465 if Token
/= Tok_With
then
466 Error_Msg_SC
("WITH expected");
471 if Token
= Tok_Private
then
473 ("PRIVATE not allowed in protected type declaration");
477 Set_Protected_Definition
(Protected_Node
, P_Protected_Definition
);
478 return Protected_Node
;
482 -------------------------------------
483 -- 9.4 Protected Type Declaration --
484 -------------------------------------
486 -- Parsed by P_Protected (9.4)
488 ---------------------------------------
489 -- 9.4 Single Protected Declaration --
490 ---------------------------------------
492 -- Parsed by P_Protected (9.4)
494 -------------------------------
495 -- 9.4 Protected Definition --
496 -------------------------------
498 -- PROTECTED_DEFINITION ::=
499 -- {PROTECTED_OPERATION_DECLARATION}
501 -- {PROTECTED_ELEMENT_DECLARATION}]
502 -- end [protected_IDENTIFIER]
504 -- PROTECTED_ELEMENT_DECLARATION ::=
505 -- PROTECTED_OPERATION_DECLARATION
506 -- | COMPONENT_DECLARATION
508 -- The caller has already established the scope stack entry
510 -- Error recovery: cannot raise Error_Resync
512 function P_Protected_Definition
return Node_Id
is
517 Def_Node
:= New_Node
(N_Protected_Definition
, Token_Ptr
);
519 -- Get rid of active SIS entry from outer scope. This means we will
520 -- miss some nested cases, but it doesn't seem worth the effort. See
521 -- discussion in Par for further details
523 SIS_Entry_Active
:= False;
525 -- Loop to scan visible declarations (protected operation declarations)
527 Set_Visible_Declarations
(Def_Node
, New_List
);
530 Item_Node
:= P_Protected_Operation_Declaration_Opt
;
531 exit when No
(Item_Node
);
532 Append
(Item_Node
, Visible_Declarations
(Def_Node
));
535 -- Deal with PRIVATE part (including graceful handling
536 -- of multiple PRIVATE parts).
538 Private_Loop
: while Token
= Tok_Private
loop
539 if No
(Private_Declarations
(Def_Node
)) then
540 Set_Private_Declarations
(Def_Node
, New_List
);
542 Error_Msg_SC
("duplicate private part");
545 Scan
; -- past PRIVATE
547 Declaration_Loop
: loop
548 if Token
= Tok_Identifier
then
549 P_Component_Items
(Private_Declarations
(Def_Node
));
551 Item_Node
:= P_Protected_Operation_Declaration_Opt
;
552 exit Declaration_Loop
when No
(Item_Node
);
553 Append
(Item_Node
, Private_Declarations
(Def_Node
));
555 end loop Declaration_Loop
;
556 end loop Private_Loop
;
558 End_Statements
(Def_Node
);
560 end P_Protected_Definition
;
562 ------------------------------------------
563 -- 9.4 Protected Operation Declaration --
564 ------------------------------------------
566 -- PROTECTED_OPERATION_DECLARATION ::=
567 -- SUBPROGRAM_DECLARATION
568 -- | ENTRY_DECLARATION
569 -- | REPRESENTATION_CLAUSE
571 -- Error recovery: cannot raise Error_Resync
573 -- Note: a pragma can also be returned in this position
575 -- We are not currently permitting representation clauses to appear as
576 -- protected operation declarations, do we have to rethink this???
578 function P_Protected_Operation_Declaration_Opt
return Node_Id
is
582 function P_Entry_Or_Subprogram_With_Indicator
return Node_Id
;
583 -- Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding
584 -- indicator. The caller has checked that the initial token is NOT or
587 ------------------------------------------
588 -- P_Entry_Or_Subprogram_With_Indicator --
589 ------------------------------------------
591 function P_Entry_Or_Subprogram_With_Indicator
return Node_Id
is
592 Decl
: Node_Id
:= Error
;
593 Is_Overriding
: Boolean := False;
594 Not_Overriding
: Boolean := False;
597 if Token
= Tok_Not
then
600 if Token
= Tok_Overriding
then
601 Scan
; -- past OVERRIDING
602 Not_Overriding
:= True;
604 Error_Msg_SC
("OVERRIDING expected!");
608 Scan
; -- past OVERRIDING
609 Is_Overriding
:= True;
612 if (Is_Overriding
or else Not_Overriding
) then
613 if Ada_Version
< Ada_05
then
614 Error_Msg_SP
(" overriding indicator is an Ada 2005 extension");
615 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
617 elsif Token
= Tok_Entry
then
618 Decl
:= P_Entry_Declaration
;
620 Set_Must_Override
(Decl
, Is_Overriding
);
621 Set_Must_Not_Override
(Decl
, Not_Overriding
);
623 elsif Token
= Tok_Function
or else Token
= Tok_Procedure
then
624 Decl
:= P_Subprogram
(Pf_Decl
);
626 Set_Must_Override
(Specification
(Decl
), Is_Overriding
);
627 Set_Must_Not_Override
(Specification
(Decl
), Not_Overriding
);
630 Error_Msg_SC
("ENTRY, FUNCTION or PROCEDURE expected!");
635 end P_Entry_Or_Subprogram_With_Indicator
;
637 -- Start of processing for P_Protected_Operation_Declaration_Opt
640 -- This loop runs more than once only when a junk declaration
644 if Token
= Tok_Pragma
then
647 elsif Token
= Tok_Not
or else Token
= Tok_Overriding
then
648 return P_Entry_Or_Subprogram_With_Indicator
;
650 elsif Token
= Tok_Entry
then
651 return P_Entry_Declaration
;
653 elsif Token
= Tok_Function
or else Token
= Tok_Procedure
then
654 return P_Subprogram
(Pf_Decl
);
656 elsif Token
= Tok_Identifier
then
659 Skip_Declaration
(L
);
661 if Nkind
(First
(L
)) = N_Object_Declaration
then
663 ("component must be declared in private part of " &
664 "protected type", P
);
667 ("illegal declaration in protected definition", P
);
670 elsif Token
in Token_Class_Declk
then
671 Error_Msg_SC
("illegal declaration in protected definition");
672 Resync_Past_Semicolon
;
674 -- Return now to avoid cascaded messages if next declaration
675 -- is a valid component declaration.
679 elsif Token
= Tok_For
then
681 ("representation clause not allowed in protected definition");
682 Resync_Past_Semicolon
;
688 end P_Protected_Operation_Declaration_Opt
;
690 -----------------------------------
691 -- 9.4 Protected Operation Item --
692 -----------------------------------
694 -- PROTECTED_OPERATION_ITEM ::=
695 -- SUBPROGRAM_DECLARATION
698 -- | REPRESENTATION_CLAUSE
700 -- This procedure parses and returns a list of protected operation items
702 -- We are not currently permitting representation clauses to appear
703 -- as protected operation items, do we have to rethink this???
705 function P_Protected_Operation_Items
return List_Id
is
709 Item_List
:= New_List
;
712 if Token
= Tok_Entry
or else Bad_Spelling_Of
(Tok_Entry
) then
713 Append
(P_Entry_Body
, Item_List
);
715 elsif Token
= Tok_Function
or else Bad_Spelling_Of
(Tok_Function
)
717 Token
= Tok_Procedure
or else Bad_Spelling_Of
(Tok_Procedure
)
719 Append
(P_Subprogram
(Pf_Decl_Pbod
), Item_List
);
721 elsif Token
= Tok_Pragma
or else Bad_Spelling_Of
(Tok_Pragma
) then
722 P_Pragmas_Opt
(Item_List
);
724 elsif Token
= Tok_Private
or else Bad_Spelling_Of
(Tok_Private
) then
725 Error_Msg_SC
("PRIVATE not allowed in protected body");
726 Scan
; -- past PRIVATE
728 elsif Token
= Tok_Identifier
then
730 ("all components must be declared in spec!");
731 Resync_Past_Semicolon
;
733 elsif Token
in Token_Class_Declk
then
734 Error_Msg_SC
("this declaration not allowed in protected body");
735 Resync_Past_Semicolon
;
743 end P_Protected_Operation_Items
;
745 ------------------------------
746 -- 9.5.2 Entry Declaration --
747 ------------------------------
749 -- ENTRY_DECLARATION ::=
750 -- [OVERRIDING_INDICATOR]
751 -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)]
752 -- PARAMETER_PROFILE;
754 -- The caller has checked that the initial token is ENTRY, NOT or
757 -- Error recovery: cannot raise Error_Resync
759 function P_Entry_Declaration
return Node_Id
is
761 Scan_State
: Saved_Scan_State
;
763 -- Flags for optional overriding indication. Two flags are needed,
764 -- to distinguish positive and negative overriding indicators from
765 -- the absence of any indicator.
767 Is_Overriding
: Boolean := False;
768 Not_Overriding
: Boolean := False;
771 -- Ada 2005 (AI-397): Scan leading overriding indicator.
773 if Token
= Tok_Not
then
776 if Token
= Tok_Overriding
then
777 Scan
; -- part OVERRIDING
778 Not_Overriding
:= True;
780 Error_Msg_SC
("OVERRIDING expected!");
783 elsif Token
= Tok_Overriding
then
784 Scan
; -- part OVERRIDING
785 Is_Overriding
:= True;
788 if (Is_Overriding
or else Not_Overriding
) then
789 if Ada_Version
< Ada_05
then
790 Error_Msg_SP
(" overriding indicator is an Ada 2005 extension");
791 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
793 elsif Token
/= Tok_Entry
then
794 Error_Msg_SC
("ENTRY expected!");
798 Decl_Node
:= New_Node
(N_Entry_Declaration
, Token_Ptr
);
801 Set_Defining_Identifier
802 (Decl_Node
, P_Defining_Identifier
(C_Left_Paren_Semicolon
));
804 -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
806 if Token
= Tok_Left_Paren
then
809 -- If identifier after left paren, could still be either
811 if Token
= Tok_Identifier
then
812 Save_Scan_State
(Scan_State
); -- at Id
815 -- If comma or colon after Id, must be Formal_Part
817 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
818 Restore_Scan_State
(Scan_State
); -- to Id
819 Set_Parameter_Specifications
(Decl_Node
, P_Formal_Part
);
821 -- Else if Id wi no comma or colon, must be discrete subtype defn
824 Restore_Scan_State
(Scan_State
); -- to Id
825 Set_Discrete_Subtype_Definition
826 (Decl_Node
, P_Discrete_Subtype_Definition
);
828 Set_Parameter_Specifications
(Decl_Node
, P_Parameter_Profile
);
831 -- If no Id, must be discrete subtype definition
834 Set_Discrete_Subtype_Definition
835 (Decl_Node
, P_Discrete_Subtype_Definition
);
837 Set_Parameter_Specifications
(Decl_Node
, P_Parameter_Profile
);
841 if Is_Overriding
then
842 Set_Must_Override
(Decl_Node
);
843 elsif Not_Overriding
then
844 Set_Must_Not_Override
(Decl_Node
);
847 -- Error recovery check for illegal return
849 if Token
= Tok_Return
then
850 Error_Msg_SC
("entry cannot have return value!");
852 Discard_Junk_Node
(P_Subtype_Indication
);
855 -- Error recovery check for improper use of entry barrier in spec
857 if Token
= Tok_When
then
858 Error_Msg_SC
("barrier not allowed here (belongs in body)");
860 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
868 Resync_Past_Semicolon
;
870 end P_Entry_Declaration
;
872 -----------------------------
873 -- 9.5.2 Accept Statement --
874 -----------------------------
876 -- ACCEPT_STATEMENT ::=
877 -- accept entry_DIRECT_NAME
878 -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do
879 -- HANDLED_SEQUENCE_OF_STATEMENTS
880 -- end [entry_IDENTIFIER]];
882 -- The caller has checked that the initial token is ACCEPT
884 -- Error recovery: cannot raise Error_Resync. If an error occurs, the
885 -- scan is resynchronized past the next semicolon and control returns.
887 function P_Accept_Statement
return Node_Id
is
888 Scan_State
: Saved_Scan_State
;
889 Accept_Node
: Node_Id
;
894 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
895 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
897 Accept_Node
:= New_Node
(N_Accept_Statement
, Token_Ptr
);
899 Scope
.Table
(Scope
.Last
).Labl
:= Token_Node
;
901 Set_Entry_Direct_Name
(Accept_Node
, P_Identifier
(C_Do
));
903 -- Left paren could be (Entry_Index) or Formal_Part, determine which
905 if Token
= Tok_Left_Paren
then
906 Save_Scan_State
(Scan_State
); -- at left paren
907 Scan
; -- past left paren
909 -- If first token after left paren not identifier, then Entry_Index
911 if Token
/= Tok_Identifier
then
912 Set_Entry_Index
(Accept_Node
, P_Expression
);
914 Set_Parameter_Specifications
(Accept_Node
, P_Parameter_Profile
);
916 -- First token after left paren is identifier, could be either case
918 else -- Token = Tok_Identifier
919 Scan
; -- past identifier
921 -- If identifier followed by comma or colon, must be Formal_Part
923 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
924 Restore_Scan_State
(Scan_State
); -- to left paren
925 Set_Parameter_Specifications
(Accept_Node
, P_Parameter_Profile
);
927 -- If identifier not followed by comma/colon, must be entry index
930 Restore_Scan_State
(Scan_State
); -- to left paren
931 Scan
; -- past left paren (again!)
932 Set_Entry_Index
(Accept_Node
, P_Expression
);
934 Set_Parameter_Specifications
(Accept_Node
, P_Parameter_Profile
);
939 -- Scan out DO if present
941 if Token
= Tok_Do
then
942 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
943 Scope
.Table
(Scope
.Last
).Lreq
:= False;
945 Hand_Seq
:= P_Handled_Sequence_Of_Statements
;
946 Set_Handled_Statement_Sequence
(Accept_Node
, Hand_Seq
);
947 End_Statements
(Handled_Statement_Sequence
(Accept_Node
));
949 -- Exception handlers not allowed in Ada 95 node
951 if Present
(Exception_Handlers
(Hand_Seq
)) then
952 if Ada_Version
= Ada_83
then
954 ("(Ada 83) exception handlers in accept not allowed",
955 First_Non_Pragma
(Exception_Handlers
(Hand_Seq
)));
960 Pop_Scope_Stack
; -- discard unused entry
966 -- If error, resynchronize past semicolon
970 Resync_Past_Semicolon
;
971 Pop_Scope_Stack
; -- discard unused entry
974 end P_Accept_Statement
;
976 ------------------------
977 -- 9.5.2 Entry Index --
978 ------------------------
980 -- Parsed by P_Expression (4.4)
982 -----------------------
983 -- 9.5.2 Entry Body --
984 -----------------------
987 -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is
990 -- HANDLED_SEQUENCE_OF_STATEMENTS
991 -- end [entry_IDENTIFIER];
993 -- The caller has checked that the initial token is ENTRY
995 -- Error_Recovery: cannot raise Error_Resync
997 function P_Entry_Body
return Node_Id
is
998 Entry_Node
: Node_Id
;
999 Formal_Part_Node
: Node_Id
;
1000 Name_Node
: Node_Id
;
1004 Entry_Node
:= New_Node
(N_Entry_Body
, Token_Ptr
);
1007 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1008 Scope
.Table
(Scope
.Last
).Lreq
:= False;
1009 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
1011 Name_Node
:= P_Defining_Identifier
;
1012 Set_Defining_Identifier
(Entry_Node
, Name_Node
);
1013 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
1015 Formal_Part_Node
:= P_Entry_Body_Formal_Part
;
1016 Set_Entry_Body_Formal_Part
(Entry_Node
, Formal_Part_Node
);
1018 Set_Condition
(Formal_Part_Node
, P_Entry_Barrier
);
1019 Parse_Decls_Begin_End
(Entry_Node
);
1023 -----------------------------------
1024 -- 9.5.2 Entry Body Formal Part --
1025 -----------------------------------
1027 -- ENTRY_BODY_FORMAL_PART ::=
1028 -- [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART]
1030 -- Error_Recovery: cannot raise Error_Resync
1032 function P_Entry_Body_Formal_Part
return Node_Id
is
1033 Fpart_Node
: Node_Id
;
1034 Scan_State
: Saved_Scan_State
;
1037 Fpart_Node
:= New_Node
(N_Entry_Body_Formal_Part
, Token_Ptr
);
1039 -- See if entry index specification present, and if so parse it
1041 if Token
= Tok_Left_Paren
then
1042 Save_Scan_State
(Scan_State
); -- at left paren
1043 Scan
; -- past left paren
1045 if Token
= Tok_For
then
1046 Set_Entry_Index_Specification
1047 (Fpart_Node
, P_Entry_Index_Specification
);
1050 Restore_Scan_State
(Scan_State
); -- to left paren
1053 -- Check for (common?) case of left paren omitted before FOR. This
1054 -- is a tricky case, because the corresponding missing left paren
1055 -- can cause real havoc if a formal part is present which gets
1056 -- treated as part of the discrete subtype definition of the
1057 -- entry index specification, so just give error and resynchronize
1059 elsif Token
= Tok_For
then
1060 T_Left_Paren
; -- to give error message
1064 Set_Parameter_Specifications
(Fpart_Node
, P_Parameter_Profile
);
1066 end P_Entry_Body_Formal_Part
;
1068 --------------------------
1069 -- 9.5.2 Entry Barrier --
1070 --------------------------
1072 -- ENTRY_BARRIER ::= when CONDITION
1074 -- Error_Recovery: cannot raise Error_Resync
1076 function P_Entry_Barrier
return Node_Id
is
1080 if Token
= Tok_When
then
1082 Bnode
:= P_Expression_No_Right_Paren
;
1084 if Token
= Tok_Colon_Equal
then
1085 Error_Msg_SC
(""":="" should be ""=""");
1087 Bnode
:= P_Expression_No_Right_Paren
;
1091 T_When
; -- to give error message
1097 end P_Entry_Barrier
;
1099 --------------------------------------
1100 -- 9.5.2 Entry Index Specification --
1101 --------------------------------------
1103 -- ENTRY_INDEX_SPECIFICATION ::=
1104 -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
1106 -- Error recovery: can raise Error_Resync
1108 function P_Entry_Index_Specification
return Node_Id
is
1109 Iterator_Node
: Node_Id
;
1112 Iterator_Node
:= New_Node
(N_Entry_Index_Specification
, Token_Ptr
);
1114 Set_Defining_Identifier
(Iterator_Node
, P_Defining_Identifier
(C_In
));
1116 Set_Discrete_Subtype_Definition
1117 (Iterator_Node
, P_Discrete_Subtype_Definition
);
1118 return Iterator_Node
;
1119 end P_Entry_Index_Specification
;
1121 ---------------------------------
1122 -- 9.5.3 Entry Call Statement --
1123 ---------------------------------
1125 -- Parsed by P_Name (4.1). Within a select, an entry call is parsed
1126 -- by P_Select_Statement (9.7)
1128 ------------------------------
1129 -- 9.5.4 Requeue Statement --
1130 ------------------------------
1132 -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort];
1134 -- The caller has checked that the initial token is requeue
1136 -- Error recovery: can raise Error_Resync
1138 function P_Requeue_Statement
return Node_Id
is
1139 Requeue_Node
: Node_Id
;
1142 Requeue_Node
:= New_Node
(N_Requeue_Statement
, Token_Ptr
);
1143 Scan
; -- past REQUEUE
1144 Set_Name
(Requeue_Node
, P_Name
);
1146 if Token
= Tok_With
then
1149 Set_Abort_Present
(Requeue_Node
, True);
1153 return Requeue_Node
;
1154 end P_Requeue_Statement
;
1156 --------------------------
1157 -- 9.6 Delay Statement --
1158 --------------------------
1160 -- DELAY_STATEMENT ::=
1161 -- DELAY_UNTIL_STATEMENT
1162 -- | DELAY_RELATIVE_STATEMENT
1164 -- The caller has checked that the initial token is DELAY
1166 -- Error recovery: cannot raise Error_Resync
1168 function P_Delay_Statement
return Node_Id
is
1172 -- The following check for delay until misused in Ada 83 doesn't catch
1173 -- all cases, but it's good enough to catch most of them!
1175 if Token_Name
= Name_Until
then
1176 Check_95_Keyword
(Tok_Until
, Tok_Left_Paren
);
1177 Check_95_Keyword
(Tok_Until
, Tok_Identifier
);
1180 if Token
= Tok_Until
then
1181 return P_Delay_Until_Statement
;
1183 return P_Delay_Relative_Statement
;
1185 end P_Delay_Statement
;
1187 --------------------------------
1188 -- 9.6 Delay Until Statement --
1189 --------------------------------
1191 -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION;
1193 -- The caller has checked that the initial token is DELAY, scanned it
1194 -- out and checked that the current token is UNTIL
1196 -- Error recovery: cannot raise Error_Resync
1198 function P_Delay_Until_Statement
return Node_Id
is
1199 Delay_Node
: Node_Id
;
1202 Delay_Node
:= New_Node
(N_Delay_Until_Statement
, Prev_Token_Ptr
);
1204 Set_Expression
(Delay_Node
, P_Expression_No_Right_Paren
);
1207 end P_Delay_Until_Statement
;
1209 -----------------------------------
1210 -- 9.6 Delay Relative Statement --
1211 -----------------------------------
1213 -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION;
1215 -- The caller has checked that the initial token is DELAY, scanned it
1216 -- out and determined that the current token is not UNTIL
1218 -- Error recovery: cannot raise Error_Resync
1220 function P_Delay_Relative_Statement
return Node_Id
is
1221 Delay_Node
: Node_Id
;
1224 Delay_Node
:= New_Node
(N_Delay_Relative_Statement
, Prev_Token_Ptr
);
1225 Set_Expression
(Delay_Node
, P_Expression_No_Right_Paren
);
1226 Check_Simple_Expression_In_Ada_83
(Expression
(Delay_Node
));
1229 end P_Delay_Relative_Statement
;
1231 ---------------------------
1232 -- 9.7 Select Statement --
1233 ---------------------------
1235 -- SELECT_STATEMENT ::=
1237 -- | TIMED_ENTRY_CALL
1238 -- | CONDITIONAL_ENTRY_CALL
1239 -- | ASYNCHRONOUS_SELECT
1241 -- SELECTIVE_ACCEPT ::=
1244 -- SELECT_ALTERNATIVE
1247 -- SELECT_ALTERNATIVE
1249 -- SEQUENCE_OF_STATEMENTS]
1252 -- GUARD ::= when CONDITION =>
1254 -- Note: the guard preceding a select alternative is included as part
1255 -- of the node generated for a selective accept alternative.
1257 -- SELECT_ALTERNATIVE ::=
1258 -- ACCEPT_ALTERNATIVE
1259 -- | DELAY_ALTERNATIVE
1260 -- | TERMINATE_ALTERNATIVE
1262 -- TIMED_ENTRY_CALL ::=
1264 -- ENTRY_CALL_ALTERNATIVE
1266 -- DELAY_ALTERNATIVE
1269 -- CONDITIONAL_ENTRY_CALL ::=
1271 -- ENTRY_CALL_ALTERNATIVE
1273 -- SEQUENCE_OF_STATEMENTS
1276 -- ENTRY_CALL_ALTERNATIVE ::=
1277 -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS]
1279 -- ASYNCHRONOUS_SELECT ::=
1281 -- TRIGGERING_ALTERNATIVE
1286 -- TRIGGERING_ALTERNATIVE ::=
1287 -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS]
1289 -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT
1291 -- The caller has checked that the initial token is SELECT
1293 -- Error recovery: can raise Error_Resync
1295 function P_Select_Statement
return Node_Id
is
1296 Select_Node
: Node_Id
;
1297 Select_Sloc
: Source_Ptr
;
1298 Stmnt_Sloc
: Source_Ptr
;
1299 Ecall_Node
: Node_Id
;
1300 Alternative
: Node_Id
;
1301 Select_Pragmas
: List_Id
;
1302 Alt_Pragmas
: List_Id
;
1303 Statement_List
: List_Id
;
1305 Cond_Expr
: Node_Id
;
1306 Delay_Stmnt
: Node_Id
;
1310 Scope
.Table
(Scope
.Last
).Etyp
:= E_Select
;
1311 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1312 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1313 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
1315 Select_Sloc
:= Token_Ptr
;
1316 Scan
; -- past SELECT
1317 Stmnt_Sloc
:= Token_Ptr
;
1318 Select_Pragmas
:= P_Pragmas_Opt
;
1320 -- If first token after select is designator, then we have an entry
1321 -- call, which must be the start of a conditional entry call, timed
1322 -- entry call or asynchronous select
1324 if Token
in Token_Class_Desig
then
1326 -- Scan entry call statement
1329 Ecall_Node
:= P_Name
;
1331 -- ?? The following two clauses exactly parallel code in ch5
1332 -- and should be commoned sometime
1334 if Nkind
(Ecall_Node
) = N_Indexed_Component
then
1336 Prefix_Node
: constant Node_Id
:= Prefix
(Ecall_Node
);
1337 Exprs_Node
: constant List_Id
:= Expressions
(Ecall_Node
);
1340 Change_Node
(Ecall_Node
, N_Procedure_Call_Statement
);
1341 Set_Name
(Ecall_Node
, Prefix_Node
);
1342 Set_Parameter_Associations
(Ecall_Node
, Exprs_Node
);
1345 elsif Nkind
(Ecall_Node
) = N_Function_Call
then
1347 Fname_Node
: constant Node_Id
:= Name
(Ecall_Node
);
1348 Params_List
: constant List_Id
:=
1349 Parameter_Associations
(Ecall_Node
);
1352 Change_Node
(Ecall_Node
, N_Procedure_Call_Statement
);
1353 Set_Name
(Ecall_Node
, Fname_Node
);
1354 Set_Parameter_Associations
(Ecall_Node
, Params_List
);
1357 elsif Nkind
(Ecall_Node
) = N_Identifier
1358 or else Nkind
(Ecall_Node
) = N_Selected_Component
1360 -- Case of a call to a parameterless entry.
1363 C_Node
: constant Node_Id
:=
1364 New_Node
(N_Procedure_Call_Statement
, Stmnt_Sloc
);
1366 Set_Name
(C_Node
, Ecall_Node
);
1367 Set_Parameter_Associations
(C_Node
, No_List
);
1368 Ecall_Node
:= C_Node
;
1375 when Error_Resync
=>
1376 Resync_Past_Semicolon
;
1380 Statement_List
:= P_Sequence_Of_Statements
(SS_Eltm_Ortm_Tatm
);
1382 -- OR follows, we have a timed entry call
1384 if Token
= Tok_Or
then
1386 Alt_Pragmas
:= P_Pragmas_Opt
;
1388 Select_Node
:= New_Node
(N_Timed_Entry_Call
, Select_Sloc
);
1389 Set_Entry_Call_Alternative
(Select_Node
,
1390 Make_Entry_Call_Alternative
(Stmnt_Sloc
,
1391 Entry_Call_Statement
=> Ecall_Node
,
1392 Pragmas_Before
=> Select_Pragmas
,
1393 Statements
=> Statement_List
));
1395 -- Only possibility is delay alternative. If we have anything
1396 -- else, give message, and treat as conditional entry call.
1398 if Token
/= Tok_Delay
then
1400 ("only allowed alternative in timed entry call is delay!");
1401 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Sreq
));
1402 Set_Delay_Alternative
(Select_Node
, Error
);
1405 Set_Delay_Alternative
(Select_Node
, P_Delay_Alternative
);
1407 (Delay_Alternative
(Select_Node
), Alt_Pragmas
);
1410 -- ELSE follows, we have a conditional entry call
1412 elsif Token
= Tok_Else
then
1414 Select_Node
:= New_Node
(N_Conditional_Entry_Call
, Select_Sloc
);
1416 Set_Entry_Call_Alternative
(Select_Node
,
1417 Make_Entry_Call_Alternative
(Stmnt_Sloc
,
1418 Entry_Call_Statement
=> Ecall_Node
,
1419 Pragmas_Before
=> Select_Pragmas
,
1420 Statements
=> Statement_List
));
1423 (Select_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1425 -- Only remaining case is THEN ABORT (asynchronous select)
1427 elsif Token
= Tok_Abort
then
1429 Make_Asynchronous_Select
(Select_Sloc
,
1430 Triggering_Alternative
=>
1431 Make_Triggering_Alternative
(Stmnt_Sloc
,
1432 Triggering_Statement
=> Ecall_Node
,
1433 Pragmas_Before
=> Select_Pragmas
,
1434 Statements
=> Statement_List
),
1435 Abortable_Part
=> P_Abortable_Part
);
1440 if Ada_Version
= Ada_83
then
1441 Error_Msg_BC
("OR or ELSE expected");
1443 Error_Msg_BC
("OR or ELSE or THEN ABORT expected");
1446 Select_Node
:= Error
;
1451 -- Here we have a selective accept or an an asynchronous select (first
1452 -- token after SELECT is other than a designator token).
1455 -- If we have delay with no guard, could be asynchronous select
1457 if Token
= Tok_Delay
then
1458 Delay_Stmnt
:= P_Delay_Statement
;
1459 Statement_List
:= P_Sequence_Of_Statements
(SS_Eltm_Ortm_Tatm
);
1461 -- Asynchronous select
1463 if Token
= Tok_Abort
then
1465 Make_Asynchronous_Select
(Select_Sloc
,
1466 Triggering_Alternative
=>
1467 Make_Triggering_Alternative
(Stmnt_Sloc
,
1468 Triggering_Statement
=> Delay_Stmnt
,
1469 Pragmas_Before
=> Select_Pragmas
,
1470 Statements
=> Statement_List
),
1471 Abortable_Part
=> P_Abortable_Part
);
1476 -- Delay which was not an asynchronous select. Must be a selective
1477 -- accept, and since at least one accept statement is required,
1478 -- we must have at least one OR phrase present.
1481 Alt_List
:= New_List
(
1482 Make_Delay_Alternative
(Stmnt_Sloc
,
1483 Delay_Statement
=> Delay_Stmnt
,
1484 Pragmas_Before
=> Select_Pragmas
,
1485 Statements
=> Statement_List
));
1487 Alt_Pragmas
:= P_Pragmas_Opt
;
1490 -- If not a delay statement, then must be another possibility for
1491 -- a selective accept alternative, or perhaps a guard is present
1494 Alt_List
:= New_List
;
1495 Alt_Pragmas
:= Select_Pragmas
;
1498 Select_Node
:= New_Node
(N_Selective_Accept
, Select_Sloc
);
1499 Set_Select_Alternatives
(Select_Node
, Alt_List
);
1501 -- Scan out selective accept alternatives. On entry to this loop,
1502 -- we are just past a SELECT or OR token, and any pragmas that
1503 -- immediately follow the SELECT or OR are in Alt_Pragmas.
1506 if Token
= Tok_When
then
1508 if Present
(Alt_Pragmas
) then
1509 Error_Msg_SC
("pragmas may not precede guard");
1513 Cond_Expr
:= P_Expression_No_Right_Paren
;
1515 Alt_Pragmas
:= P_Pragmas_Opt
;
1521 if Token
= Tok_Accept
then
1522 Alternative
:= P_Accept_Alternative
;
1524 -- Check for junk attempt at asynchronous select using
1525 -- an Accept alternative as the triggering statement
1527 if Token
= Tok_Abort
1528 and then Is_Empty_List
(Alt_List
)
1529 and then No
(Cond_Expr
)
1532 ("triggering statement must be entry call or delay",
1533 Sloc
(Alternative
));
1534 Scan
; -- past junk ABORT
1535 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Sreq
));
1540 elsif Token
= Tok_Delay
then
1541 Alternative
:= P_Delay_Alternative
;
1543 elsif Token
= Tok_Terminate
then
1544 Alternative
:= P_Terminate_Alternative
;
1548 ("Select alternative (ACCEPT, ABORT, DELAY) expected");
1549 Alternative
:= Error
;
1551 if Token
= Tok_Semicolon
then
1552 Scan
; -- past junk semicolon
1556 -- THEN ABORT at this stage is just junk
1558 if Token
= Tok_Abort
then
1559 Error_Msg_SP
("misplaced `THEN ABORT`");
1560 Scan
; -- past junk ABORT
1561 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Sreq
));
1566 if Alternative
/= Error
then
1567 Set_Condition
(Alternative
, Cond_Expr
);
1568 Set_Pragmas_Before
(Alternative
, Alt_Pragmas
);
1569 Append
(Alternative
, Alt_List
);
1572 exit when Token
/= Tok_Or
;
1576 Alt_Pragmas
:= P_Pragmas_Opt
;
1579 if Token
= Tok_Else
then
1582 (Select_Node
, P_Sequence_Of_Statements
(SS_Ortm_Sreq
));
1584 if Token
= Tok_Or
then
1585 Error_Msg_SC
("select alternative cannot follow else part!");
1593 end P_Select_Statement
;
1595 -----------------------------
1596 -- 9.7.1 Selective Accept --
1597 -----------------------------
1599 -- Parsed by P_Select_Statement (9.7)
1605 -- Parsed by P_Select_Statement (9.7)
1607 -------------------------------
1608 -- 9.7.1 Select Alternative --
1609 -------------------------------
1611 -- SELECT_ALTERNATIVE ::=
1612 -- ACCEPT_ALTERNATIVE
1613 -- | DELAY_ALTERNATIVE
1614 -- | TERMINATE_ALTERNATIVE
1616 -- Note: the guard preceding a select alternative is included as part
1617 -- of the node generated for a selective accept alternative.
1619 -- Error recovery: cannot raise Error_Resync
1621 -------------------------------
1622 -- 9.7.1 Accept Alternative --
1623 -------------------------------
1625 -- ACCEPT_ALTERNATIVE ::=
1626 -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
1628 -- Error_Recovery: Cannot raise Error_Resync
1630 -- Note: the caller is responsible for setting the Pragmas_Before
1631 -- field of the returned N_Terminate_Alternative node.
1633 function P_Accept_Alternative
return Node_Id
is
1634 Accept_Alt_Node
: Node_Id
;
1637 Accept_Alt_Node
:= New_Node
(N_Accept_Alternative
, Token_Ptr
);
1638 Set_Accept_Statement
(Accept_Alt_Node
, P_Accept_Statement
);
1640 -- Note: the reason that we accept THEN ABORT as a terminator for
1641 -- the sequence of statements is for error recovery which allows
1642 -- for misuse of an accept statement as a triggering statememt.
1645 (Accept_Alt_Node
, P_Sequence_Of_Statements
(SS_Eltm_Ortm_Tatm
));
1646 return Accept_Alt_Node
;
1647 end P_Accept_Alternative
;
1649 ------------------------------
1650 -- 9.7.1 Delay Alternative --
1651 ------------------------------
1653 -- DELAY_ALTERNATIVE ::=
1654 -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
1656 -- Error_Recovery: Cannot raise Error_Resync
1658 -- Note: the caller is responsible for setting the Pragmas_Before
1659 -- field of the returned N_Terminate_Alternative node.
1661 function P_Delay_Alternative
return Node_Id
is
1662 Delay_Alt_Node
: Node_Id
;
1665 Delay_Alt_Node
:= New_Node
(N_Delay_Alternative
, Token_Ptr
);
1666 Set_Delay_Statement
(Delay_Alt_Node
, P_Delay_Statement
);
1668 -- Note: the reason that we accept THEN ABORT as a terminator for
1669 -- the sequence of statements is for error recovery which allows
1670 -- for misuse of an accept statement as a triggering statememt.
1673 (Delay_Alt_Node
, P_Sequence_Of_Statements
(SS_Eltm_Ortm_Tatm
));
1674 return Delay_Alt_Node
;
1675 end P_Delay_Alternative
;
1677 ----------------------------------
1678 -- 9.7.1 Terminate Alternative --
1679 ----------------------------------
1681 -- TERMINATE_ALTERNATIVE ::= terminate;
1683 -- Error_Recovery: Cannot raise Error_Resync
1685 -- Note: the caller is responsible for setting the Pragmas_Before
1686 -- field of the returned N_Terminate_Alternative node.
1688 function P_Terminate_Alternative
return Node_Id
is
1689 Terminate_Alt_Node
: Node_Id
;
1692 Terminate_Alt_Node
:= New_Node
(N_Terminate_Alternative
, Token_Ptr
);
1693 Scan
; -- past TERMINATE
1696 -- For all other select alternatives, the sequence of statements
1697 -- after the alternative statement will swallow up any pragmas
1698 -- coming in this position. But the terminate alternative has no
1699 -- sequence of statements, so the pragmas here must be treated
1702 Set_Pragmas_After
(Terminate_Alt_Node
, P_Pragmas_Opt
);
1703 return Terminate_Alt_Node
;
1704 end P_Terminate_Alternative
;
1706 -----------------------------
1707 -- 9.7.2 Timed Entry Call --
1708 -----------------------------
1710 -- Parsed by P_Select_Statement (9.7)
1712 -----------------------------------
1713 -- 9.7.2 Entry Call Alternative --
1714 -----------------------------------
1716 -- Parsed by P_Select_Statement (9.7)
1718 -----------------------------------
1719 -- 9.7.3 Conditional Entry Call --
1720 -----------------------------------
1722 -- Parsed by P_Select_Statement (9.7)
1724 --------------------------------
1725 -- 9.7.4 Asynchronous Select --
1726 --------------------------------
1728 -- Parsed by P_Select_Statement (9.7)
1730 -----------------------------------
1731 -- 9.7.4 Triggering Alternative --
1732 -----------------------------------
1734 -- Parsed by P_Select_Statement (9.7)
1736 ---------------------------------
1737 -- 9.7.4 Triggering Statement --
1738 ---------------------------------
1740 -- Parsed by P_Select_Statement (9.7)
1742 ---------------------------
1743 -- 9.7.4 Abortable Part --
1744 ---------------------------
1746 -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
1748 -- The caller has verified that THEN ABORT is present, and Token is
1749 -- pointing to the ABORT on entry (or if not, then we have an error)
1751 -- Error recovery: cannot raise Error_Resync
1753 function P_Abortable_Part
return Node_Id
is
1754 Abortable_Part_Node
: Node_Id
;
1757 Abortable_Part_Node
:= New_Node
(N_Abortable_Part
, Token_Ptr
);
1758 T_Abort
; -- scan past ABORT
1760 if Ada_Version
= Ada_83
then
1761 Error_Msg_SP
("(Ada 83) asynchronous select not allowed!");
1764 Set_Statements
(Abortable_Part_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1765 return Abortable_Part_Node
;
1766 end P_Abortable_Part
;
1768 --------------------------
1769 -- 9.8 Abort Statement --
1770 --------------------------
1772 -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
1774 -- The caller has checked that the initial token is ABORT
1776 -- Error recovery: cannot raise Error_Resync
1778 function P_Abort_Statement
return Node_Id
is
1779 Abort_Node
: Node_Id
;
1782 Abort_Node
:= New_Node
(N_Abort_Statement
, Token_Ptr
);
1784 Set_Names
(Abort_Node
, New_List
);
1787 Append
(P_Name
, Names
(Abort_Node
));
1788 exit when Token
/= Tok_Comma
;
1794 end P_Abort_Statement
;