1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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.
30 with Sinfo
.CN
; use Sinfo
.CN
;
35 -- Local functions, used only in this chapter
37 function P_Case_Statement
return Node_Id
;
38 function P_Case_Statement_Alternative
return Node_Id
;
39 function P_Exit_Statement
return Node_Id
;
40 function P_Goto_Statement
return Node_Id
;
41 function P_If_Statement
return Node_Id
;
42 function P_Label
return Node_Id
;
43 function P_Null_Statement
return Node_Id
;
45 function P_Assignment_Statement
(LHS
: Node_Id
) return Node_Id
;
46 -- Parse assignment statement. On entry, the caller has scanned the left
47 -- hand side (passed in as Lhs), and the colon-equal (or some symbol
48 -- taken to be an error equivalent such as equal).
50 function P_Begin_Statement
(Block_Name
: Node_Id
:= Empty
) return Node_Id
;
51 -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is
52 -- the N_Identifier node for the label on the block. If Block_Name is
53 -- Empty on entry (the default), then the block statement is unlabeled.
55 function P_Declare_Statement
(Block_Name
: Node_Id
:= Empty
) return Node_Id
;
56 -- Parse declare block. If Block_Name is non-Empty on entry, it is
57 -- the N_Identifier node for the label on the block. If Block_Name is
58 -- Empty on entry (the default), then the block statement is unlabeled.
60 function P_For_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
;
61 -- Parse for statement. If Loop_Name is non-Empty on entry, it is
62 -- the N_Identifier node for the label on the loop. If Loop_Name is
63 -- Empty on entry (the default), then the for statement is unlabeled.
65 function P_Iterator_Specification
(Def_Id
: Node_Id
) return Node_Id
;
66 -- Parse an iterator specification. The defining identifier has already
67 -- been scanned, as it is the common prefix between loop and iterator
70 function P_Loop_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
;
71 -- Parse loop statement. If Loop_Name is non-Empty on entry, it is
72 -- the N_Identifier node for the label on the loop. If Loop_Name is
73 -- Empty on entry (the default), then the loop statement is unlabeled.
75 function P_While_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
;
76 -- Parse while statement. If Loop_Name is non-Empty on entry, it is
77 -- the N_Identifier node for the label on the loop. If Loop_Name is
78 -- Empty on entry (the default), then the while statement is unlabeled.
80 function Set_Loop_Block_Name
(L
: Character) return Name_Id
;
81 -- Given a letter 'L' for a loop or 'B' for a block, returns a name
82 -- of the form L_nn or B_nn where nn is a serial number obtained by
83 -- incrementing the variable Loop_Block_Count.
86 -- Scan past THEN token, testing for illegal junk after it
88 ---------------------------------
89 -- 5.1 Sequence of Statements --
90 ---------------------------------
92 -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} {LABEL}
93 -- Note: the final label is an Ada 2012 addition.
96 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
98 -- SIMPLE_STATEMENT ::= NULL_STATEMENT
99 -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT
100 -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT
101 -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT
102 -- | REQUEUE_STATEMENT | DELAY_STATEMENT
103 -- | ABORT_STATEMENT | RAISE_STATEMENT
106 -- COMPOUND_STATEMENT ::=
107 -- IF_STATEMENT | CASE_STATEMENT
108 -- | LOOP_STATEMENT | BLOCK_STATEMENT
109 -- | ACCEPT_STATEMENT | SELECT_STATEMENT
111 -- This procedure scans a sequence of statements. The caller sets SS_Flags
112 -- to indicate acceptable termination conditions for the sequence:
114 -- SS_Flags.Eftm Terminate on ELSIF
115 -- SS_Flags.Eltm Terminate on ELSE
116 -- SS_Flags.Extm Terminate on EXCEPTION
117 -- SS_Flags.Ortm Terminate on OR
118 -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return)
119 -- SS_Flags.Whtm Terminate on WHEN
120 -- SS_Flags.Unco Unconditional terminate after scanning one statement
122 -- In addition, the scan is always terminated by encountering END or the
123 -- end of file (EOF) condition. If one of the six above terminators is
124 -- encountered with the corresponding SS_Flags flag not set, then the
125 -- action taken is as follows:
127 -- If the keyword occurs to the left of the expected column of the end
128 -- for the current sequence (as recorded in the current end context),
129 -- then it is assumed to belong to an outer context, and is considered
130 -- to terminate the sequence of statements.
132 -- If the keyword occurs to the right of, or in the expected column of
133 -- the end for the current sequence, then an error message is output,
134 -- the keyword together with its associated context is skipped, and
135 -- the statement scan continues until another terminator is found.
137 -- Note that the first action means that control can return to the caller
138 -- with Token set to a terminator other than one of those specified by the
139 -- SS parameter. The caller should treat such a case as equivalent to END.
141 -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at
142 -- least one real statement (other than a pragma) is required in the
143 -- statement sequence. During the processing of the sequence, this
144 -- flag is manipulated to indicate the current status of the requirement
145 -- for a statement. For example, it is turned off by the occurrence of a
146 -- statement, and back on by a label (which requires a following statement)
148 -- Error recovery: cannot raise Error_Resync. If an error occurs during
149 -- parsing a statement, then the scan pointer is advanced past the next
150 -- semicolon and the parse continues.
152 function P_Sequence_Of_Statements
(SS_Flags
: SS_Rec
) return List_Id
is
154 Statement_Required
: Boolean;
155 -- This flag indicates if a subsequent statement (other than a pragma)
156 -- is required. It is initialized from the Sreq flag, and modified as
157 -- statements are scanned (a statement turns it off, and a label turns
158 -- it back on again since a statement must follow a label).
159 -- Note : this final requirement is lifted in Ada 2012.
161 Statement_Seen
: Boolean;
162 -- In Ada 2012, a label can end a sequence of statements, but the
163 -- sequence cannot contain only labels. This flag is set whenever a
164 -- label is encountered, to enforce this rule at the end of a sequence.
166 Declaration_Found
: Boolean := False;
167 -- This flag is set True if a declaration is encountered, so that the
168 -- error message about declarations in the statement part is only
169 -- given once for a given sequence of statements.
171 Scan_State_Label
: Saved_Scan_State
;
172 Scan_State
: Saved_Scan_State
;
174 Statement_List
: List_Id
;
175 Block_Label
: Name_Id
;
179 procedure Junk_Declaration
;
180 -- Procedure called to handle error of declaration encountered in
181 -- statement sequence.
183 procedure Test_Statement_Required
;
184 -- Flag error if Statement_Required flag set
186 ----------------------
187 -- Junk_Declaration --
188 ----------------------
190 procedure Junk_Declaration
is
192 if (not Declaration_Found
) or All_Errors_Mode
then
193 Error_Msg_SC
-- CODEFIX
194 ("declarations must come before BEGIN");
195 Declaration_Found
:= True;
198 Skip_Declaration
(Statement_List
);
199 end Junk_Declaration
;
201 -----------------------------
202 -- Test_Statement_Required --
203 -----------------------------
205 procedure Test_Statement_Required
is
206 function All_Pragmas
return Boolean;
207 -- Return True if statement list is all pragmas
213 function All_Pragmas
return Boolean is
216 S
:= First
(Statement_List
);
217 while Present
(S
) loop
218 if Nkind
(S
) /= N_Pragma
then
228 -- Start of processing for Test_Statement_Required
231 if Statement_Required
then
233 -- Check no statement required after label in Ada 2012, and that
234 -- it is OK to have nothing but pragmas in a statement sequence.
236 if Ada_Version
>= Ada_2012
237 and then not Is_Empty_List
(Statement_List
)
239 ((Nkind
(Last
(Statement_List
)) = N_Label
240 and then Statement_Seen
)
244 Null_Stm
: constant Node_Id
:=
245 Make_Null_Statement
(Token_Ptr
);
247 Set_Comes_From_Source
(Null_Stm
, False);
248 Append_To
(Statement_List
, Null_Stm
);
251 -- If not Ada 2012, or not special case above, give error message
254 Error_Msg_BC
-- CODEFIX
255 ("statement expected");
258 end Test_Statement_Required
;
260 -- Start of processing for P_Sequence_Of_Statements
263 Statement_List
:= New_List
;
264 Statement_Required
:= SS_Flags
.Sreq
;
265 Statement_Seen
:= False;
268 Ignore
(Tok_Semicolon
);
272 Style
.Check_Indentation
;
275 -- Deal with reserved identifier (in assignment or call)
277 if Is_Reserved_Identifier
then
278 Save_Scan_State
(Scan_State
); -- at possible bad identifier
279 Scan
; -- and scan past it
281 -- We have an reserved word which is spelled in identifier
282 -- style, so the question is whether it really is intended
283 -- to be an identifier.
286 -- If followed by a semicolon, then it is an identifier,
287 -- with the exception of the cases tested for below.
289 (Token
= Tok_Semicolon
290 and then Prev_Token
/= Tok_Return
291 and then Prev_Token
/= Tok_Null
292 and then Prev_Token
/= Tok_Raise
293 and then Prev_Token
/= Tok_End
294 and then Prev_Token
/= Tok_Exit
)
296 -- If followed by colon, colon-equal, or dot, then we
297 -- definitely have an identifier (could not be reserved)
299 or else Token
= Tok_Colon
300 or else Token
= Tok_Colon_Equal
301 or else Token
= Tok_Dot
303 -- Left paren means we have an identifier except for those
304 -- reserved words that can legitimately be followed by a
308 (Token
= Tok_Left_Paren
309 and then Prev_Token
/= Tok_Case
310 and then Prev_Token
/= Tok_Delay
311 and then Prev_Token
/= Tok_If
312 and then Prev_Token
/= Tok_Elsif
313 and then Prev_Token
/= Tok_Return
314 and then Prev_Token
/= Tok_When
315 and then Prev_Token
/= Tok_While
316 and then Prev_Token
/= Tok_Separate
)
318 -- Here we have an apparent reserved identifier and the
319 -- token past it is appropriate to this usage (and would
320 -- be a definite error if this is not an identifier). What
321 -- we do is to use P_Identifier to fix up the identifier,
322 -- and then fall into the normal processing.
324 Restore_Scan_State
(Scan_State
); -- back to the ID
325 Scan_Reserved_Identifier
(Force_Msg
=> False);
327 -- Not a reserved identifier after all (or at least we can't
328 -- be sure that it is), so reset the scan and continue.
331 Restore_Scan_State
(Scan_State
); -- back to the reserved word
335 -- Now look to see what kind of statement we have
339 -- Case of end or EOF
341 when Tok_End | Tok_EOF
=>
343 -- These tokens always terminate the statement sequence
345 Test_Statement_Required
;
352 -- Terminate if Eftm set or if the ELSIF is to the left
353 -- of the expected column of the end for this sequence
356 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
358 Test_Statement_Required
;
361 -- Otherwise complain and skip past ELSIF Condition then
364 Error_Msg_SC
("ELSIF not allowed here");
366 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
368 Statement_Required
:= False;
375 -- Terminate if Eltm set or if the else is to the left
376 -- of the expected column of the end for this sequence
379 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
381 Test_Statement_Required
;
384 -- Otherwise complain and skip past else
387 Error_Msg_SC
("ELSE not allowed here");
389 Statement_Required
:= False;
394 when Tok_Exception
=>
395 Test_Statement_Required
;
397 -- If Extm not set and the exception is not to the left of
398 -- the expected column of the end for this sequence, then we
399 -- assume it belongs to the current sequence, even though it
402 if not SS_Flags
.Extm
and then
403 Start_Column
>= Scope
.Table
(Scope
.Last
).Ecol
406 Error_Msg_SC
("exception handler not permitted here");
407 Scan
; -- past EXCEPTION
408 Discard_Junk_List
(Parse_Exception_Handlers
);
411 -- Always return, in the case where we scanned out handlers
412 -- that we did not expect, Parse_Exception_Handlers returned
413 -- with Token being either end or EOF, so we are OK.
421 -- Terminate if Ortm set or if the or is to the left of the
422 -- expected column of the end for this sequence.
425 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
427 Test_Statement_Required
;
430 -- Otherwise complain and skip past or
433 Error_Msg_SC
("OR not allowed here");
435 Statement_Required
:= False;
438 -- Case of THEN (deal also with THEN ABORT)
441 Save_Scan_State
(Scan_State
); -- at THEN
444 -- Terminate if THEN ABORT allowed (ATC case)
446 exit when SS_Flags
.Tatm
and then Token
= Tok_Abort
;
448 -- Otherwise we treat THEN as some kind of mess where we did
449 -- not see the associated IF, but we pick up assuming it had
452 Restore_Scan_State
(Scan_State
); -- to THEN
453 Append_To
(Statement_List
, P_If_Statement
);
454 Statement_Required
:= False;
456 -- Case of WHEN (error because we are not in a case)
458 when Tok_When | Tok_Others
=>
460 -- Terminate if Whtm set or if the WHEN is to the left of
461 -- the expected column of the end for this sequence.
464 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
466 Test_Statement_Required
;
469 -- Otherwise complain and skip when Choice {| Choice} =>
472 Error_Msg_SC
("WHEN not allowed here");
474 Discard_Junk_List
(P_Discrete_Choice_List
);
476 Statement_Required
:= False;
479 -- Cases of statements starting with an identifier
481 when Tok_Identifier
=>
484 -- Save scan pointers and line number in case block label
486 Id_Node
:= Token_Node
;
487 Block_Label
:= Token_Name
;
488 Save_Scan_State
(Scan_State_Label
); -- at possible label
491 -- Check for common case of assignment, since it occurs
492 -- frequently, and we want to process it efficiently.
494 if Token
= Tok_Colon_Equal
then
495 Scan
; -- past the colon-equal
496 Append_To
(Statement_List
,
497 P_Assignment_Statement
(Id_Node
));
498 Statement_Required
:= False;
500 -- Check common case of procedure call, another case that
501 -- we want to speed up as much as possible.
503 elsif Token
= Tok_Semicolon
then
504 Change_Name_To_Procedure_Call_Statement
(Id_Node
);
505 Append_To
(Statement_List
, Id_Node
);
506 Scan
; -- past semicolon
507 Statement_Required
:= False;
509 -- Check for case of "go to" in place of "goto"
511 elsif Token
= Tok_Identifier
512 and then Block_Label
= Name_Go
513 and then Token_Name
= Name_To
515 Error_Msg_SP
-- CODEFIX
516 ("goto is one word");
517 Append_To
(Statement_List
, P_Goto_Statement
);
518 Statement_Required
:= False;
520 -- Check common case of = used instead of :=, just so we
521 -- give a better error message for this special misuse.
523 elsif Token
= Tok_Equal
then
524 T_Colon_Equal
; -- give := expected message
525 Append_To
(Statement_List
,
526 P_Assignment_Statement
(Id_Node
));
527 Statement_Required
:= False;
529 -- Check case of loop label or block label
531 elsif Token
= Tok_Colon
532 or else (Token
in Token_Class_Labeled_Stmt
533 and then not Token_Is_At_Start_Of_Line
)
535 T_Colon
; -- past colon (if there, or msg for missing one)
537 -- Test for more than one label
540 exit when Token
/= Tok_Identifier
;
541 Save_Scan_State
(Scan_State
); -- at second Id
544 if Token
= Tok_Colon
then
546 ("only one label allowed on block or loop");
547 Scan
; -- past colon on extra label
549 -- Use the second label as the "real" label
551 Scan_State_Label
:= Scan_State
;
553 -- We will set Error_name as the Block_Label since
554 -- we really don't know which of the labels might
555 -- be used at the end of the loop or block!
557 Block_Label
:= Error_Name
;
559 -- If Id with no colon, then backup to point to the
560 -- Id and we will issue the message below when we try
561 -- to scan out the statement as some other form.
564 Restore_Scan_State
(Scan_State
); -- to second Id
569 -- Loop_Statement (labeled Loop_Statement)
571 if Token
= Tok_Loop
then
572 Append_To
(Statement_List
,
573 P_Loop_Statement
(Id_Node
));
575 -- While statement (labeled loop statement with WHILE)
577 elsif Token
= Tok_While
then
578 Append_To
(Statement_List
,
579 P_While_Statement
(Id_Node
));
581 -- Declare statement (labeled block statement with
584 elsif Token
= Tok_Declare
then
585 Append_To
(Statement_List
,
586 P_Declare_Statement
(Id_Node
));
588 -- Begin statement (labeled block statement with no
591 elsif Token
= Tok_Begin
then
592 Append_To
(Statement_List
,
593 P_Begin_Statement
(Id_Node
));
595 -- For statement (labeled loop statement with FOR)
597 elsif Token
= Tok_For
then
598 Append_To
(Statement_List
,
599 P_For_Statement
(Id_Node
));
601 -- Improper statement follows label. If we have an
602 -- expression token, then assume the colon was part
603 -- of a misplaced declaration.
605 elsif Token
not in Token_Class_Eterm
then
606 Restore_Scan_State
(Scan_State_Label
);
609 -- Otherwise complain we have inappropriate statement
613 ("loop or block statement must follow label");
616 Statement_Required
:= False;
618 -- Here we have an identifier followed by something
619 -- other than a colon, semicolon or assignment symbol.
620 -- The only valid possibility is a name extension symbol
622 elsif Token
in Token_Class_Namext
then
623 Restore_Scan_State
(Scan_State_Label
); -- to Id
626 -- Skip junk right parens in this context
628 Ignore
(Tok_Right_Paren
);
630 -- Check context following call
632 if Token
= Tok_Colon_Equal
then
633 Scan
; -- past colon equal
634 Append_To
(Statement_List
,
635 P_Assignment_Statement
(Name_Node
));
636 Statement_Required
:= False;
638 -- Check common case of = used instead of :=
640 elsif Token
= Tok_Equal
then
641 T_Colon_Equal
; -- give := expected message
642 Append_To
(Statement_List
,
643 P_Assignment_Statement
(Name_Node
));
644 Statement_Required
:= False;
646 -- Check apostrophe cases
648 elsif Token
= Tok_Apostrophe
then
649 Append_To
(Statement_List
,
650 P_Code_Statement
(Name_Node
));
651 Statement_Required
:= False;
653 -- The only other valid item after a name is ; which
654 -- means that the item we just scanned was a call.
656 elsif Token
= Tok_Semicolon
then
657 Change_Name_To_Procedure_Call_Statement
(Name_Node
);
658 Append_To
(Statement_List
, Name_Node
);
659 Scan
; -- past semicolon
660 Statement_Required
:= False;
662 -- A slash following an identifier or a selected
663 -- component in this situation is most likely a period
664 -- (see location of keys on keyboard).
666 elsif Token
= Tok_Slash
667 and then (Nkind
(Name_Node
) = N_Identifier
669 Nkind
(Name_Node
) = N_Selected_Component
)
671 Error_Msg_SC
-- CODEFIX
672 ("""/"" should be "".""");
673 Statement_Required
:= False;
676 -- Else we have a missing semicolon
680 Statement_Required
:= False;
683 -- If junk after identifier, check if identifier is an
684 -- instance of an incorrectly spelled keyword. If so, we
685 -- do nothing. The Bad_Spelling_Of will have reset Token
686 -- to the appropriate keyword, so the next time round the
687 -- loop we will process the modified token. Note that we
688 -- check for ELSIF before ELSE here. That's not accidental.
689 -- We don't want to identify a misspelling of ELSE as
690 -- ELSIF, and in particular we do not want to treat ELSEIF
694 Restore_Scan_State
(Scan_State_Label
); -- to identifier
696 if Bad_Spelling_Of
(Tok_Abort
)
697 or else Bad_Spelling_Of
(Tok_Accept
)
698 or else Bad_Spelling_Of
(Tok_Case
)
699 or else Bad_Spelling_Of
(Tok_Declare
)
700 or else Bad_Spelling_Of
(Tok_Delay
)
701 or else Bad_Spelling_Of
(Tok_Elsif
)
702 or else Bad_Spelling_Of
(Tok_Else
)
703 or else Bad_Spelling_Of
(Tok_End
)
704 or else Bad_Spelling_Of
(Tok_Exception
)
705 or else Bad_Spelling_Of
(Tok_Exit
)
706 or else Bad_Spelling_Of
(Tok_For
)
707 or else Bad_Spelling_Of
(Tok_Goto
)
708 or else Bad_Spelling_Of
(Tok_If
)
709 or else Bad_Spelling_Of
(Tok_Loop
)
710 or else Bad_Spelling_Of
(Tok_Or
)
711 or else Bad_Spelling_Of
(Tok_Pragma
)
712 or else Bad_Spelling_Of
(Tok_Raise
)
713 or else Bad_Spelling_Of
(Tok_Requeue
)
714 or else Bad_Spelling_Of
(Tok_Return
)
715 or else Bad_Spelling_Of
(Tok_Select
)
716 or else Bad_Spelling_Of
(Tok_When
)
717 or else Bad_Spelling_Of
(Tok_While
)
721 -- If not a bad spelling, then we really have junk
724 Scan
; -- past identifier again
726 -- If next token is first token on line, then we
727 -- consider that we were missing a semicolon after
728 -- the identifier, and process it as a procedure
729 -- call with no parameters.
731 if Token_Is_At_Start_Of_Line
then
732 Change_Name_To_Procedure_Call_Statement
(Id_Node
);
733 Append_To
(Statement_List
, Id_Node
);
734 T_Semicolon
; -- to give error message
735 Statement_Required
:= False;
737 -- Otherwise we give a missing := message and
738 -- simply abandon the junk that is there now.
741 T_Colon_Equal
; -- give := expected message
748 -- Statement starting with operator symbol. This could be
749 -- a call, a name starting an assignment, or a qualified
752 when Tok_Operator_Symbol
=>
756 -- An attempt at a range attribute or a qualified expression
757 -- must be illegal here (a code statement cannot possibly
758 -- allow qualification by a function name).
760 if Token
= Tok_Apostrophe
then
761 Error_Msg_SC
("apostrophe illegal here");
765 -- Scan possible assignment if we have a name
767 if Expr_Form
= EF_Name
768 and then Token
= Tok_Colon_Equal
770 Scan
; -- past colon equal
771 Append_To
(Statement_List
,
772 P_Assignment_Statement
(Name_Node
));
774 Change_Name_To_Procedure_Call_Statement
(Name_Node
);
775 Append_To
(Statement_List
, Name_Node
);
779 Statement_Required
:= False;
781 -- Label starting with << which must precede real statement
782 -- Note: in Ada 2012, the label may end the sequence.
784 when Tok_Less_Less
=>
785 if Present
(Last
(Statement_List
))
786 and then Nkind
(Last
(Statement_List
)) /= N_Label
788 Statement_Seen
:= True;
791 Append_To
(Statement_List
, P_Label
);
792 Statement_Required
:= True;
794 -- Pragma appearing as a statement in a statement sequence
798 Append_To
(Statement_List
, P_Pragma
);
804 Append_To
(Statement_List
, P_Abort_Statement
);
805 Statement_Required
:= False;
811 Append_To
(Statement_List
, P_Accept_Statement
);
812 Statement_Required
:= False;
814 -- Begin_Statement (Block_Statement with no declare, no label)
818 Append_To
(Statement_List
, P_Begin_Statement
);
819 Statement_Required
:= False;
825 Append_To
(Statement_List
, P_Case_Statement
);
826 Statement_Required
:= False;
828 -- Block_Statement with DECLARE and no label
832 Append_To
(Statement_List
, P_Declare_Statement
);
833 Statement_Required
:= False;
839 Append_To
(Statement_List
, P_Delay_Statement
);
840 Statement_Required
:= False;
846 Append_To
(Statement_List
, P_Exit_Statement
);
847 Statement_Required
:= False;
849 -- Loop_Statement with FOR and no label
853 Append_To
(Statement_List
, P_For_Statement
);
854 Statement_Required
:= False;
860 Append_To
(Statement_List
, P_Goto_Statement
);
861 Statement_Required
:= False;
867 Append_To
(Statement_List
, P_If_Statement
);
868 Statement_Required
:= False;
874 Append_To
(Statement_List
, P_Loop_Statement
);
875 Statement_Required
:= False;
881 Append_To
(Statement_List
, P_Null_Statement
);
882 Statement_Required
:= False;
888 Append_To
(Statement_List
, P_Raise_Statement
);
889 Statement_Required
:= False;
895 Append_To
(Statement_List
, P_Requeue_Statement
);
896 Statement_Required
:= False;
902 Append_To
(Statement_List
, P_Return_Statement
);
903 Statement_Required
:= False;
909 Append_To
(Statement_List
, P_Select_Statement
);
910 Statement_Required
:= False;
912 -- While_Statement (Block_Statement with while and no loop)
916 Append_To
(Statement_List
, P_While_Statement
);
917 Statement_Required
:= False;
919 -- Anything else is some kind of junk, signal an error message
920 -- and then raise Error_Resync, to merge with the normal
921 -- handling of a bad statement.
925 if Token
in Token_Class_Declk
then
929 Error_Msg_BC
-- CODEFIX
930 ("statement expected");
935 -- On error resynchronization, skip past next semicolon, and, since
936 -- we are still in the statement loop, look for next statement. We
937 -- set Statement_Required False to avoid an unnecessary error message
938 -- complaining that no statement was found (i.e. we consider the
939 -- junk to satisfy the requirement for a statement being present).
943 Resync_Past_Semicolon_Or_To_Loop_Or_Then
;
944 Statement_Required
:= False;
947 exit when SS_Flags
.Unco
;
951 return Statement_List
;
953 end P_Sequence_Of_Statements
;
959 ---------------------------
960 -- 5.1 Simple Statement --
961 ---------------------------
963 -- Parsed by P_Sequence_Of_Statements (5.1)
965 -----------------------------
966 -- 5.1 Compound Statement --
967 -----------------------------
969 -- Parsed by P_Sequence_Of_Statements (5.1)
971 -------------------------
972 -- 5.1 Null Statement --
973 -------------------------
975 -- NULL_STATEMENT ::= null;
977 -- The caller has already checked that the current token is null
979 -- Error recovery: cannot raise Error_Resync
981 function P_Null_Statement
return Node_Id
is
982 Null_Stmt_Node
: Node_Id
;
985 Null_Stmt_Node
:= New_Node
(N_Null_Statement
, Token_Ptr
);
988 return Null_Stmt_Node
;
989 end P_Null_Statement
;
995 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
997 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
999 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
1000 -- (not an OPERATOR_SYMBOL)
1002 -- The caller has already checked that the current token is <<
1004 -- Error recovery: can raise Error_Resync
1006 function P_Label
return Node_Id
is
1007 Label_Node
: Node_Id
;
1010 Label_Node
:= New_Node
(N_Label
, Token_Ptr
);
1012 Set_Identifier
(Label_Node
, P_Identifier
(C_Greater_Greater
));
1014 Append_Elmt
(Label_Node
, Label_List
);
1018 -------------------------------
1019 -- 5.1 Statement Identifier --
1020 -------------------------------
1022 -- Statement label is parsed by P_Label (5.1)
1024 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1025 -- or P_While_Statement (5.5)
1027 -- Block label is parsed by P_Begin_Statement (5.6) or
1028 -- P_Declare_Statement (5.6)
1030 -------------------------------
1031 -- 5.2 Assignment Statement --
1032 -------------------------------
1034 -- ASSIGNMENT_STATEMENT ::=
1035 -- variable_NAME := EXPRESSION;
1037 -- Error recovery: can raise Error_Resync
1039 function P_Assignment_Statement
(LHS
: Node_Id
) return Node_Id
is
1040 Assign_Node
: Node_Id
;
1043 Assign_Node
:= New_Node
(N_Assignment_Statement
, Prev_Token_Ptr
);
1044 Set_Name
(Assign_Node
, LHS
);
1045 Set_Expression
(Assign_Node
, P_Expression_No_Right_Paren
);
1048 end P_Assignment_Statement
;
1050 -----------------------
1051 -- 5.3 If Statement --
1052 -----------------------
1055 -- if CONDITION then
1056 -- SEQUENCE_OF_STATEMENTS
1057 -- {elsif CONDITION then
1058 -- SEQUENCE_OF_STATEMENTS}
1060 -- SEQUENCE_OF_STATEMENTS]
1063 -- The caller has checked that the initial token is IF (or in the error
1064 -- case of a mysterious THEN, the initial token may simply be THEN, in
1065 -- which case, no condition (or IF) was scanned).
1067 -- Error recovery: can raise Error_Resync
1069 function P_If_Statement
return Node_Id
is
1071 Elsif_Node
: Node_Id
;
1074 procedure Add_Elsif_Part
;
1075 -- An internal procedure used to scan out a single ELSIF part. On entry
1076 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1077 -- scanned out and is in Prev_Token.
1079 procedure Check_If_Column
;
1080 -- An internal procedure used to check that THEN, ELSE, or ELSIF
1081 -- appear in the right place if column checking is enabled (i.e. if
1082 -- they are the first token on the line, then they must appear in
1083 -- the same column as the opening IF).
1085 procedure Check_Then_Column
;
1086 -- This procedure carries out the style checks for a THEN token
1087 -- Note that the caller has set Loc to the Source_Ptr value for
1088 -- the previous IF or ELSIF token. These checks apply only to a
1089 -- THEN at the start of a line.
1091 function Else_Should_Be_Elsif
return Boolean;
1092 -- An internal routine used to do a special error recovery check when
1093 -- an ELSE is encountered. It determines if the ELSE should be treated
1094 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1095 -- is followed by a sequence of tokens, starting on the same line as
1096 -- the ELSE, which are not expression terminators, followed by a THEN.
1097 -- On entry, the ELSE has been scanned out.
1099 procedure Add_Elsif_Part
is
1101 if No
(Elsif_Parts
(If_Node
)) then
1102 Set_Elsif_Parts
(If_Node
, New_List
);
1105 Elsif_Node
:= New_Node
(N_Elsif_Part
, Prev_Token_Ptr
);
1106 Loc
:= Prev_Token_Ptr
;
1107 Set_Condition
(Elsif_Node
, P_Condition
);
1111 (Elsif_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1112 Append
(Elsif_Node
, Elsif_Parts
(If_Node
));
1115 procedure Check_If_Column
is
1117 if RM_Column_Check
and then Token_Is_At_Start_Of_Line
1118 and then Start_Column
/= Scope
.Table
(Scope
.Last
).Ecol
1120 Error_Msg_Col
:= Scope
.Table
(Scope
.Last
).Ecol
;
1121 Error_Msg_SC
("(style) this token should be@");
1123 end Check_If_Column
;
1125 procedure Check_Then_Column
is
1127 if Token_Is_At_Start_Of_Line
and then Token
= Tok_Then
then
1131 Style
.Check_Then
(Loc
);
1134 end Check_Then_Column
;
1136 function Else_Should_Be_Elsif
return Boolean is
1137 Scan_State
: Saved_Scan_State
;
1140 if Token_Is_At_Start_Of_Line
then
1144 Save_Scan_State
(Scan_State
);
1147 if Token
in Token_Class_Eterm
then
1148 Restore_Scan_State
(Scan_State
);
1151 Scan
; -- past non-expression terminating token
1153 if Token
= Tok_Then
then
1154 Restore_Scan_State
(Scan_State
);
1160 end Else_Should_Be_Elsif
;
1162 -- Start of processing for P_If_Statement
1165 If_Node
:= New_Node
(N_If_Statement
, Token_Ptr
);
1168 Scope
.Table
(Scope
.Last
).Etyp
:= E_If
;
1169 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1170 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1171 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
1172 Scope
.Table
(Scope
.Last
).Node
:= If_Node
;
1174 if Token
= Tok_If
then
1177 Set_Condition
(If_Node
, P_Condition
);
1179 -- Deal with misuse of IF expression => used instead
1180 -- of WHEN expression =>
1182 if Token
= Tok_Arrow
then
1183 Error_Msg_SC
-- CODEFIX
1185 Scan
; -- past the arrow
1186 Pop_Scope_Stack
; -- remove unneeded entry
1193 Error_Msg_SC
("no IF for this THEN");
1194 Set_Condition
(If_Node
, Error
);
1200 (If_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1202 -- This loop scans out else and elsif parts
1205 if Token
= Tok_Elsif
then
1208 if Present
(Else_Statements
(If_Node
)) then
1209 Error_Msg_SP
("ELSIF cannot appear after ELSE");
1215 elsif Token
= Tok_Else
then
1219 if Else_Should_Be_Elsif
then
1220 Error_Msg_SP
-- CODEFIX
1221 ("ELSE should be ELSIF");
1225 -- Here we have an else that really is an else
1227 if Present
(Else_Statements
(If_Node
)) then
1228 Error_Msg_SP
("only one ELSE part allowed");
1230 (P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
),
1231 Else_Statements
(If_Node
));
1234 (If_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1238 -- If anything other than ELSE or ELSIF, exit the loop. The token
1239 -- had better be END (and in fact it had better be END IF), but
1240 -- we will let End_Statements take care of checking that.
1252 --------------------
1254 --------------------
1256 -- CONDITION ::= boolean_EXPRESSION
1258 function P_Condition
return Node_Id
is
1262 Cond
:= P_Expression_No_Right_Paren
;
1264 -- It is never possible for := to follow a condition, so if we get
1265 -- a := we assume it is a mistyped equality. Note that we do not try
1266 -- to reconstruct the tree correctly in this case, but we do at least
1267 -- give an accurate error message.
1269 if Token
= Tok_Colon_Equal
then
1270 while Token
= Tok_Colon_Equal
loop
1271 Error_Msg_SC
-- CODEFIX
1272 (""":="" should be ""=""");
1273 Scan
; -- past junk :=
1274 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
1279 -- Otherwise check for redundant parentheses
1281 -- If the condition is a conditional or a quantified expression, it is
1282 -- parenthesized in the context of a condition, because of a separate
1286 if Style_Check
and then Paren_Count
(Cond
) > 0 then
1287 if not Nkind_In
(Cond
, N_If_Expression
,
1289 N_Quantified_Expression
)
1290 or else Paren_Count
(Cond
) > 1
1292 Style
.Check_Xtra_Parens
(First_Sloc
(Cond
));
1296 -- And return the result
1302 -------------------------
1303 -- 5.4 Case Statement --
1304 -------------------------
1306 -- CASE_STATEMENT ::=
1307 -- case EXPRESSION is
1308 -- CASE_STATEMENT_ALTERNATIVE
1309 -- {CASE_STATEMENT_ALTERNATIVE}
1312 -- The caller has checked that the first token is CASE
1314 -- Can raise Error_Resync
1316 function P_Case_Statement
return Node_Id
is
1317 Case_Node
: Node_Id
;
1318 Alternatives_List
: List_Id
;
1319 First_When_Loc
: Source_Ptr
;
1322 Case_Node
:= New_Node
(N_Case_Statement
, Token_Ptr
);
1325 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
1326 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1327 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1328 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
1329 Scope
.Table
(Scope
.Last
).Node
:= Case_Node
;
1332 Set_Expression
(Case_Node
, P_Expression_No_Right_Paren
);
1335 -- Prepare to parse case statement alternatives
1337 Alternatives_List
:= New_List
;
1338 P_Pragmas_Opt
(Alternatives_List
);
1339 First_When_Loc
:= Token_Ptr
;
1341 -- Loop through case statement alternatives
1344 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1345 -- that it is a semantic check to ensure the proper use of OTHERS
1347 if Token
= Tok_When
or else Token
= Tok_Others
then
1348 Append
(P_Case_Statement_Alternative
, Alternatives_List
);
1350 -- If we have an END, then probably we are at the end of the case
1351 -- but we only exit if Check_End thinks the END was reasonable.
1353 elsif Token
= Tok_End
then
1354 exit when Check_End
;
1356 -- Here if token is other than WHEN, OTHERS or END. We definitely
1357 -- have an error, but the question is whether or not to get out of
1358 -- the case statement. We don't want to get out early, or we will
1359 -- get a slew of junk error messages for subsequent when tokens.
1361 -- If the token is not at the start of the line, or if it is indented
1362 -- with respect to the current case statement, then the best guess is
1363 -- that we are still supposed to be inside the case statement. We
1364 -- complain about the missing WHEN, and discard the junk statements.
1366 elsif not Token_Is_At_Start_Of_Line
1367 or else Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
1369 Error_Msg_BC
("WHEN (case statement alternative) expected");
1371 -- Here is a possibility for infinite looping if we don't make
1372 -- progress. So try to process statements, otherwise exit
1375 Error_Ptr
: constant Source_Ptr
:= Scan_Ptr
;
1377 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Whtm
));
1378 exit when Scan_Ptr
= Error_Ptr
and then Check_End
;
1381 -- Here we have a junk token at the start of the line and it is
1382 -- not indented. If Check_End thinks there is a missing END, then
1383 -- we will get out of the case, otherwise we keep going.
1386 exit when Check_End
;
1390 -- Make sure we have at least one alternative
1392 if No
(First_Non_Pragma
(Alternatives_List
)) then
1394 ("WHEN expected, must have at least one alternative in case",
1399 Set_Alternatives
(Case_Node
, Alternatives_List
);
1402 end P_Case_Statement
;
1404 -------------------------------------
1405 -- 5.4 Case Statement Alternative --
1406 -------------------------------------
1408 -- CASE_STATEMENT_ALTERNATIVE ::=
1409 -- when DISCRETE_CHOICE_LIST =>
1410 -- SEQUENCE_OF_STATEMENTS
1412 -- The caller has checked that the initial token is WHEN or OTHERS
1413 -- Error recovery: can raise Error_Resync
1415 function P_Case_Statement_Alternative
return Node_Id
is
1416 Case_Alt_Node
: Node_Id
;
1420 Style
.Check_Indentation
;
1423 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Token_Ptr
);
1424 T_When
; -- past WHEN (or give error in OTHERS case)
1425 Set_Discrete_Choices
(Case_Alt_Node
, P_Discrete_Choice_List
);
1427 Set_Statements
(Case_Alt_Node
, P_Sequence_Of_Statements
(SS_Sreq_Whtm
));
1428 return Case_Alt_Node
;
1429 end P_Case_Statement_Alternative
;
1431 -------------------------
1432 -- 5.5 Loop Statement --
1433 -------------------------
1435 -- LOOP_STATEMENT ::=
1436 -- [LOOP_STATEMENT_IDENTIFIER:]
1437 -- [ITERATION_SCHEME] loop
1438 -- SEQUENCE_OF_STATEMENTS
1439 -- end loop [loop_IDENTIFIER];
1441 -- ITERATION_SCHEME ::=
1443 -- | for LOOP_PARAMETER_SPECIFICATION
1445 -- The parsing of loop statements is handled by one of three functions
1446 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1447 -- on the initial keyword in the construct (excluding the identifier)
1451 -- This function parses the case where no iteration scheme is present
1453 -- The caller has checked that the initial token is LOOP. The parameter
1454 -- is the node identifiers for the loop label if any (or is set to Empty
1455 -- if there is no loop label).
1457 -- Error recovery : cannot raise Error_Resync
1459 function P_Loop_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1460 Loop_Node
: Node_Id
;
1461 Created_Name
: Node_Id
;
1465 Scope
.Table
(Scope
.Last
).Labl
:= Loop_Name
;
1466 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1467 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1468 Scope
.Table
(Scope
.Last
).Etyp
:= E_Loop
;
1470 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1473 if No
(Loop_Name
) then
1475 Make_Identifier
(Sloc
(Loop_Node
), Set_Loop_Block_Name
('L'));
1476 Set_Comes_From_Source
(Created_Name
, False);
1477 Set_Has_Created_Identifier
(Loop_Node
, True);
1478 Set_Identifier
(Loop_Node
, Created_Name
);
1479 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1481 Set_Identifier
(Loop_Node
, Loop_Name
);
1484 Append_Elmt
(Loop_Node
, Label_List
);
1485 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1486 End_Statements
(Loop_Node
);
1488 end P_Loop_Statement
;
1492 -- This function parses a loop statement with a FOR iteration scheme
1494 -- The caller has checked that the initial token is FOR. The parameter
1495 -- is the node identifier for the block label if any (or is set to Empty
1496 -- if there is no block label).
1498 -- Note: the caller fills in the Identifier field if a label was present
1500 -- Error recovery: can raise Error_Resync
1502 function P_For_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1503 Loop_Node
: Node_Id
;
1504 Iter_Scheme_Node
: Node_Id
;
1505 Loop_For_Flag
: Boolean;
1506 Created_Name
: Node_Id
;
1511 Scope
.Table
(Scope
.Last
).Labl
:= Loop_Name
;
1512 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1513 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1514 Scope
.Table
(Scope
.Last
).Etyp
:= E_Loop
;
1516 Loop_For_Flag
:= (Prev_Token
= Tok_Loop
);
1518 Iter_Scheme_Node
:= New_Node
(N_Iteration_Scheme
, Token_Ptr
);
1519 Spec
:= P_Loop_Parameter_Specification
;
1521 if Nkind
(Spec
) = N_Loop_Parameter_Specification
then
1522 Set_Loop_Parameter_Specification
(Iter_Scheme_Node
, Spec
);
1524 Set_Iterator_Specification
(Iter_Scheme_Node
, Spec
);
1527 -- The following is a special test so that a miswritten for loop such
1528 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1529 -- entry in the scope stack. We don't bother to actually fix up the
1530 -- tree in this case since it's not worth the effort. Instead we just
1531 -- eat up the loop junk, leaving the entry for what now looks like an
1532 -- unmodified loop intact.
1534 if Loop_For_Flag
and then Token
= Tok_Semicolon
then
1535 Error_Msg_SC
("LOOP belongs here, not before FOR");
1542 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1544 if No
(Loop_Name
) then
1546 Make_Identifier
(Sloc
(Loop_Node
), Set_Loop_Block_Name
('L'));
1547 Set_Comes_From_Source
(Created_Name
, False);
1548 Set_Has_Created_Identifier
(Loop_Node
, True);
1549 Set_Identifier
(Loop_Node
, Created_Name
);
1550 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1552 Set_Identifier
(Loop_Node
, Loop_Name
);
1556 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1557 End_Statements
(Loop_Node
);
1558 Set_Iteration_Scheme
(Loop_Node
, Iter_Scheme_Node
);
1559 Append_Elmt
(Loop_Node
, Label_List
);
1562 end P_For_Statement
;
1564 -- P_While_Statement
1566 -- This procedure scans a loop statement with a WHILE iteration scheme
1568 -- The caller has checked that the initial token is WHILE. The parameter
1569 -- is the node identifier for the block label if any (or is set to Empty
1570 -- if there is no block label).
1572 -- Error recovery: cannot raise Error_Resync
1574 function P_While_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1575 Loop_Node
: Node_Id
;
1576 Iter_Scheme_Node
: Node_Id
;
1577 Loop_While_Flag
: Boolean;
1578 Created_Name
: Node_Id
;
1582 Scope
.Table
(Scope
.Last
).Labl
:= Loop_Name
;
1583 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1584 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1585 Scope
.Table
(Scope
.Last
).Etyp
:= E_Loop
;
1587 Loop_While_Flag
:= (Prev_Token
= Tok_Loop
);
1588 Iter_Scheme_Node
:= New_Node
(N_Iteration_Scheme
, Token_Ptr
);
1590 Set_Condition
(Iter_Scheme_Node
, P_Condition
);
1592 -- The following is a special test so that a miswritten for loop such
1593 -- as "loop while I > 10;" is handled nicely, without making an extra
1594 -- entry in the scope stack. We don't bother to actually fix up the
1595 -- tree in this case since it's not worth the effort. Instead we just
1596 -- eat up the loop junk, leaving the entry for what now looks like an
1597 -- unmodified loop intact.
1599 if Loop_While_Flag
and then Token
= Tok_Semicolon
then
1600 Error_Msg_SC
("LOOP belongs here, not before WHILE");
1607 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1610 if No
(Loop_Name
) then
1612 Make_Identifier
(Sloc
(Loop_Node
), Set_Loop_Block_Name
('L'));
1613 Set_Comes_From_Source
(Created_Name
, False);
1614 Set_Has_Created_Identifier
(Loop_Node
, True);
1615 Set_Identifier
(Loop_Node
, Created_Name
);
1616 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1618 Set_Identifier
(Loop_Node
, Loop_Name
);
1621 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1622 End_Statements
(Loop_Node
);
1623 Set_Iteration_Scheme
(Loop_Node
, Iter_Scheme_Node
);
1624 Append_Elmt
(Loop_Node
, Label_List
);
1627 end P_While_Statement
;
1629 ---------------------------------------
1630 -- 5.5 Loop Parameter Specification --
1631 ---------------------------------------
1633 -- LOOP_PARAMETER_SPECIFICATION ::=
1634 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1636 -- Error recovery: cannot raise Error_Resync
1638 function P_Loop_Parameter_Specification
return Node_Id
is
1639 Loop_Param_Specification_Node
: Node_Id
;
1642 Scan_State
: Saved_Scan_State
;
1646 Save_Scan_State
(Scan_State
);
1647 ID_Node
:= P_Defining_Identifier
(C_In
);
1649 -- If the next token is OF, it indicates an Ada 2012 iterator. If the
1650 -- next token is a colon, this is also an Ada 2012 iterator, including
1651 -- a subtype indication for the loop parameter. Otherwise we parse the
1652 -- construct as a loop parameter specification. Note that the form
1653 -- "for A in B" is ambiguous, and must be resolved semantically: if B
1654 -- is a discrete subtype this is a loop specification, but if it is an
1655 -- expression it is an iterator specification. Ambiguity is resolved
1656 -- during analysis of the loop parameter specification.
1658 if Token
= Tok_Of
or else Token
= Tok_Colon
then
1659 if Ada_Version
< Ada_2012
then
1660 Error_Msg_SC
("iterator is an Ada 2012 feature");
1663 return P_Iterator_Specification
(ID_Node
);
1666 -- The span of the Loop_Parameter_Specification starts at the
1667 -- defining identifier.
1669 Loop_Param_Specification_Node
:=
1670 New_Node
(N_Loop_Parameter_Specification
, Sloc
(ID_Node
));
1671 Set_Defining_Identifier
(Loop_Param_Specification_Node
, ID_Node
);
1673 if Token
= Tok_Left_Paren
then
1674 Error_Msg_SC
("subscripted loop parameter not allowed");
1675 Restore_Scan_State
(Scan_State
);
1676 Discard_Junk_Node
(P_Name
);
1678 elsif Token
= Tok_Dot
then
1679 Error_Msg_SC
("selected loop parameter not allowed");
1680 Restore_Scan_State
(Scan_State
);
1681 Discard_Junk_Node
(P_Name
);
1686 if Token
= Tok_Reverse
then
1687 Scan
; -- past REVERSE
1688 Set_Reverse_Present
(Loop_Param_Specification_Node
, True);
1691 Set_Discrete_Subtype_Definition
1692 (Loop_Param_Specification_Node
, P_Discrete_Subtype_Definition
);
1693 return Loop_Param_Specification_Node
;
1696 when Error_Resync
=>
1698 end P_Loop_Parameter_Specification
;
1700 ----------------------------------
1701 -- 5.5.1 Iterator_Specification --
1702 ----------------------------------
1704 function P_Iterator_Specification
(Def_Id
: Node_Id
) return Node_Id
is
1708 Node1
:= New_Node
(N_Iterator_Specification
, Sloc
(Def_Id
));
1709 Set_Defining_Identifier
(Node1
, Def_Id
);
1711 if Token
= Tok_Colon
then
1713 Set_Subtype_Indication
(Node1
, P_Subtype_Indication
);
1716 if Token
= Tok_Of
then
1717 Set_Of_Present
(Node1
);
1720 elsif Token
= Tok_In
then
1727 if Token
= Tok_Reverse
then
1728 Scan
; -- past REVERSE
1729 Set_Reverse_Present
(Node1
, True);
1732 Set_Name
(Node1
, P_Name
);
1734 end P_Iterator_Specification
;
1736 --------------------------
1737 -- 5.6 Block Statement --
1738 --------------------------
1740 -- BLOCK_STATEMENT ::=
1741 -- [block_STATEMENT_IDENTIFIER:]
1743 -- DECLARATIVE_PART]
1745 -- HANDLED_SEQUENCE_OF_STATEMENTS
1746 -- end [block_IDENTIFIER];
1748 -- The parsing of block statements is handled by one of the two functions
1749 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1750 -- a declare section is present
1752 -- P_Declare_Statement
1754 -- This function parses a block statement with DECLARE present
1756 -- The caller has checked that the initial token is DECLARE
1758 -- Error recovery: cannot raise Error_Resync
1760 function P_Declare_Statement
1761 (Block_Name
: Node_Id
:= Empty
)
1764 Block_Node
: Node_Id
;
1765 Created_Name
: Node_Id
;
1768 Block_Node
:= New_Node
(N_Block_Statement
, Token_Ptr
);
1771 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
1772 Scope
.Table
(Scope
.Last
).Lreq
:= Present
(Block_Name
);
1773 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1774 Scope
.Table
(Scope
.Last
).Labl
:= Block_Name
;
1775 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1777 Scan
; -- past DECLARE
1779 if No
(Block_Name
) then
1781 Make_Identifier
(Sloc
(Block_Node
), Set_Loop_Block_Name
('B'));
1782 Set_Comes_From_Source
(Created_Name
, False);
1783 Set_Has_Created_Identifier
(Block_Node
, True);
1784 Set_Identifier
(Block_Node
, Created_Name
);
1785 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1787 Set_Identifier
(Block_Node
, Block_Name
);
1790 Append_Elmt
(Block_Node
, Label_List
);
1791 Parse_Decls_Begin_End
(Block_Node
);
1793 end P_Declare_Statement
;
1795 -- P_Begin_Statement
1797 -- This function parses a block statement with no DECLARE present
1799 -- The caller has checked that the initial token is BEGIN
1801 -- Error recovery: cannot raise Error_Resync
1803 function P_Begin_Statement
1804 (Block_Name
: Node_Id
:= Empty
)
1807 Block_Node
: Node_Id
;
1808 Created_Name
: Node_Id
;
1811 Block_Node
:= New_Node
(N_Block_Statement
, Token_Ptr
);
1814 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
1815 Scope
.Table
(Scope
.Last
).Lreq
:= Present
(Block_Name
);
1816 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1817 Scope
.Table
(Scope
.Last
).Labl
:= Block_Name
;
1818 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1820 if No
(Block_Name
) then
1822 Make_Identifier
(Sloc
(Block_Node
), Set_Loop_Block_Name
('B'));
1823 Set_Comes_From_Source
(Created_Name
, False);
1824 Set_Has_Created_Identifier
(Block_Node
, True);
1825 Set_Identifier
(Block_Node
, Created_Name
);
1826 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1828 Set_Identifier
(Block_Node
, Block_Name
);
1831 Append_Elmt
(Block_Node
, Label_List
);
1833 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1834 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1836 Set_Handled_Statement_Sequence
1837 (Block_Node
, P_Handled_Sequence_Of_Statements
);
1838 End_Statements
(Handled_Statement_Sequence
(Block_Node
));
1840 end P_Begin_Statement
;
1842 -------------------------
1843 -- 5.7 Exit Statement --
1844 -------------------------
1846 -- EXIT_STATEMENT ::=
1847 -- exit [loop_NAME] [when CONDITION];
1849 -- The caller has checked that the initial token is EXIT
1851 -- Error recovery: can raise Error_Resync
1853 function P_Exit_Statement
return Node_Id
is
1854 Exit_Node
: Node_Id
;
1856 function Missing_Semicolon_On_Exit
return Boolean;
1857 -- This function deals with the following specialized situation
1860 -- exit [identifier]
1863 -- This looks like a messed up EXIT WHEN, when in fact the problem
1864 -- is a missing semicolon. It is called with Token pointing to the
1865 -- WHEN token, and returns True if a semicolon is missing before
1866 -- the WHEN as in the above example.
1868 -------------------------------
1869 -- Missing_Semicolon_On_Exit --
1870 -------------------------------
1872 function Missing_Semicolon_On_Exit
return Boolean is
1873 State
: Saved_Scan_State
;
1876 if not Token_Is_At_Start_Of_Line
then
1879 elsif Scope
.Table
(Scope
.Last
).Etyp
/= E_Case
then
1883 Save_Scan_State
(State
);
1885 Scan
; -- past token after WHEN
1887 if Token
= Tok_Arrow
then
1888 Restore_Scan_State
(State
);
1891 Restore_Scan_State
(State
);
1895 end Missing_Semicolon_On_Exit
;
1897 -- Start of processing for P_Exit_Statement
1900 Exit_Node
:= New_Node
(N_Exit_Statement
, Token_Ptr
);
1903 if Token
= Tok_Identifier
then
1904 Set_Name
(Exit_Node
, P_Qualified_Simple_Name
);
1906 elsif Style_Check
then
1907 -- This EXIT has no name, so check that
1908 -- the innermost loop is unnamed too.
1910 Check_No_Exit_Name
:
1911 for J
in reverse 1 .. Scope
.Last
loop
1912 if Scope
.Table
(J
).Etyp
= E_Loop
then
1913 if Present
(Scope
.Table
(J
).Labl
)
1914 and then Comes_From_Source
(Scope
.Table
(J
).Labl
)
1916 -- Innermost loop in fact had a name, style check fails
1918 Style
.No_Exit_Name
(Scope
.Table
(J
).Labl
);
1921 exit Check_No_Exit_Name
;
1923 end loop Check_No_Exit_Name
;
1926 if Token
= Tok_When
and then not Missing_Semicolon_On_Exit
then
1928 Set_Condition
(Exit_Node
, P_Condition
);
1930 -- Allow IF instead of WHEN, giving error message
1932 elsif Token
= Tok_If
then
1934 Scan
; -- past IF used in place of WHEN
1935 Set_Condition
(Exit_Node
, P_Expression_No_Right_Paren
);
1940 end P_Exit_Statement
;
1942 -------------------------
1943 -- 5.8 Goto Statement --
1944 -------------------------
1946 -- GOTO_STATEMENT ::= goto label_NAME;
1948 -- The caller has checked that the initial token is GOTO (or TO in the
1949 -- error case where GO and TO were incorrectly separated).
1951 -- Error recovery: can raise Error_Resync
1953 function P_Goto_Statement
return Node_Id
is
1954 Goto_Node
: Node_Id
;
1957 Goto_Node
:= New_Node
(N_Goto_Statement
, Token_Ptr
);
1958 Scan
; -- past GOTO (or TO)
1959 Set_Name
(Goto_Node
, P_Qualified_Simple_Name_Resync
);
1960 Append_Elmt
(Goto_Node
, Goto_List
);
1964 end P_Goto_Statement
;
1966 ---------------------------
1967 -- Parse_Decls_Begin_End --
1968 ---------------------------
1970 -- This function parses the construct:
1974 -- HANDLED_SEQUENCE_OF_STATEMENTS
1977 -- The caller has built the scope stack entry, and created the node to
1978 -- whose Declarations and Handled_Statement_Sequence fields are to be
1979 -- set. On return these fields are filled in (except in the case of a
1980 -- task body, where the handled statement sequence is optional, and may
1981 -- thus be Empty), and the scan is positioned past the End sequence.
1983 -- If the BEGIN is missing, then the parent node is used to help construct
1984 -- an appropriate missing BEGIN message. Possibilities for the parent are:
1986 -- N_Block_Statement declare block
1987 -- N_Entry_Body entry body
1988 -- N_Package_Body package body (begin part optional)
1989 -- N_Subprogram_Body procedure or function body
1990 -- N_Task_Body task body
1992 -- Note: in the case of a block statement, there is definitely a DECLARE
1993 -- present (because a Begin statement without a DECLARE is handled by the
1994 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
1996 -- Error recovery: cannot raise Error_Resync
1998 procedure Parse_Decls_Begin_End
(Parent
: Node_Id
) is
1999 Body_Decl
: Node_Id
;
2001 Parent_Nkind
: Node_Kind
;
2002 Spec_Node
: Node_Id
;
2005 procedure Missing_Begin
(Msg
: String);
2006 -- Called to post a missing begin message. In the normal case this is
2007 -- posted at the start of the current token. A special case arises when
2008 -- P_Declarative_Items has previously found a missing begin, in which
2009 -- case we replace the original error message.
2011 procedure Set_Null_HSS
(Parent
: Node_Id
);
2012 -- Construct an empty handled statement sequence and install in Parent
2013 -- Leaves HSS set to reference the newly constructed statement sequence.
2019 procedure Missing_Begin
(Msg
: String) is
2021 if Missing_Begin_Msg
= No_Error_Msg
then
2024 Change_Error_Text
(Missing_Begin_Msg
, Msg
);
2026 -- Purge any messages issued after than, since a missing begin
2027 -- can cause a lot of havoc, and it is better not to dump these
2028 -- cascaded messages on the user.
2030 Purge_Messages
(Get_Location
(Missing_Begin_Msg
), Prev_Token_Ptr
);
2038 procedure Set_Null_HSS
(Parent
: Node_Id
) is
2043 Make_Null_Statement
(Token_Ptr
);
2044 Set_Comes_From_Source
(Null_Stm
, False);
2047 Make_Handled_Sequence_Of_Statements
(Token_Ptr
,
2048 Statements
=> New_List
(Null_Stm
));
2049 Set_Comes_From_Source
(HSS
, False);
2051 Set_Handled_Statement_Sequence
(Parent
, HSS
);
2054 -- Start of processing for Parse_Decls_Begin_End
2057 Decls
:= P_Declarative_Part
;
2059 if Ada_Version
= Ada_83
then
2060 Check_Later_Vs_Basic_Declarations
(Decls
, During_Parsing
=> True);
2063 -- Here is where we deal with the case of IS used instead of semicolon.
2064 -- Specifically, if the last declaration in the declarative part is a
2065 -- subprogram body still marked as having a bad IS, then this is where
2066 -- we decide that the IS should really have been a semicolon and that
2067 -- the body should have been a declaration. Note that if the bad IS
2068 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2069 -- then the Bad_Is_Detected flag would have been reset by now.
2071 Body_Decl
:= Last
(Decls
);
2073 if Present
(Body_Decl
)
2074 and then Nkind
(Body_Decl
) = N_Subprogram_Body
2075 and then Bad_Is_Detected
(Body_Decl
)
2077 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2078 -- What we have now is a subprogram body with attached declarations
2079 -- and a possible statement sequence.
2081 -- First step is to take the declarations that were part of the bogus
2082 -- subprogram body and append them to the outer declaration chain.
2083 -- In other words we append them past the body (which we will later
2084 -- convert into a declaration).
2086 Append_List
(Declarations
(Body_Decl
), Decls
);
2088 -- Now take the handled statement sequence of the bogus body and
2089 -- set it as the statement sequence for the outer construct. Note
2090 -- that it may be empty (we specially allowed a missing BEGIN for
2091 -- a subprogram body marked as having a bad IS -- see below).
2093 Set_Handled_Statement_Sequence
(Parent
,
2094 Handled_Statement_Sequence
(Body_Decl
));
2096 -- Next step is to convert the old body node to a declaration node
2098 Spec_Node
:= Specification
(Body_Decl
);
2099 Change_Node
(Body_Decl
, N_Subprogram_Declaration
);
2100 Set_Specification
(Body_Decl
, Spec_Node
);
2102 -- Final step is to put the declarations for the parent where
2103 -- they belong, and then fall through the IF to scan out the
2106 Set_Declarations
(Parent
, Decls
);
2108 -- This is the normal case (i.e. any case except the bad IS case)
2109 -- If we have a BEGIN, then scan out the sequence of statements, and
2110 -- also reset the expected column for the END to match the BEGIN.
2113 Set_Declarations
(Parent
, Decls
);
2115 if Token
= Tok_Begin
then
2117 Style
.Check_Indentation
;
2120 Error_Msg_Col
:= Scope
.Table
(Scope
.Last
).Ecol
;
2123 and then Token_Is_At_Start_Of_Line
2124 and then Start_Column
/= Error_Msg_Col
2126 Error_Msg_SC
("(style) BEGIN in wrong column, should be@");
2129 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
2132 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
2134 Set_Handled_Statement_Sequence
(Parent
,
2135 P_Handled_Sequence_Of_Statements
);
2140 Parent_Nkind
:= Nkind
(Parent
);
2142 -- A special check for the missing IS case. If we have a
2143 -- subprogram body that was marked as having a suspicious
2144 -- IS, and the current token is END, then we simply confirm
2145 -- the suspicion, and do not require a BEGIN to be present
2147 if Parent_Nkind
= N_Subprogram_Body
2148 and then Token
= Tok_End
2149 and then Scope
.Table
(Scope
.Last
).Etyp
= E_Suspicious_Is
2151 Scope
.Table
(Scope
.Last
).Etyp
:= E_Bad_Is
;
2153 -- Otherwise BEGIN is not required for a package body, so we
2154 -- don't mind if it is missing, but we do construct a dummy
2155 -- one (so that we have somewhere to set End_Label).
2157 -- However if we have something other than a BEGIN which
2158 -- looks like it might be statements, then we signal a missing
2159 -- BEGIN for these cases as well. We define "something which
2160 -- looks like it might be statements" as a token other than
2161 -- END, EOF, or a token which starts declarations.
2163 elsif Parent_Nkind
= N_Package_Body
2164 and then (Token
= Tok_End
2165 or else Token
= Tok_EOF
2166 or else Token
in Token_Class_Declk
)
2168 Set_Null_HSS
(Parent
);
2170 -- These are cases in which a BEGIN is required and not present
2173 Set_Null_HSS
(Parent
);
2175 -- Prepare to issue error message
2177 Error_Msg_Sloc
:= Scope
.Table
(Scope
.Last
).Sloc
;
2178 Error_Msg_Node_1
:= Scope
.Table
(Scope
.Last
).Labl
;
2180 -- Now issue appropriate message
2182 if Parent_Nkind
= N_Block_Statement
then
2183 Missing_Begin
("missing BEGIN for DECLARE#!");
2185 elsif Parent_Nkind
= N_Entry_Body
then
2186 Missing_Begin
("missing BEGIN for ENTRY#!");
2188 elsif Parent_Nkind
= N_Subprogram_Body
then
2189 if Nkind
(Specification
(Parent
))
2190 = N_Function_Specification
2192 Missing_Begin
("missing BEGIN for function&#!");
2194 Missing_Begin
("missing BEGIN for procedure&#!");
2197 -- The case for package body arises only when
2198 -- we have possible statement junk present.
2200 elsif Parent_Nkind
= N_Package_Body
then
2201 Missing_Begin
("missing BEGIN for package body&#!");
2204 pragma Assert
(Parent_Nkind
= N_Task_Body
);
2205 Missing_Begin
("missing BEGIN for task body&#!");
2208 -- Here we pick up the statements after the BEGIN that
2209 -- should have been present but was not. We don't insist
2210 -- on statements being present if P_Declarative_Part had
2211 -- already found a missing BEGIN, since it might have
2212 -- swallowed a lone statement into the declarative part.
2214 if Missing_Begin_Msg
/= No_Error_Msg
2215 and then Token
= Tok_End
2219 Set_Handled_Statement_Sequence
(Parent
,
2220 P_Handled_Sequence_Of_Statements
);
2226 -- Here with declarations and handled statement sequence scanned
2228 if Present
(Handled_Statement_Sequence
(Parent
)) then
2229 End_Statements
(Handled_Statement_Sequence
(Parent
));
2234 -- We know that End_Statements removed an entry from the scope stack
2235 -- (because it is required to do so under all circumstances). We can
2236 -- therefore reference the entry it removed one past the stack top.
2237 -- What we are interested in is whether it was a case of a bad IS.
2239 if Scope
.Table
(Scope
.Last
+ 1).Etyp
= E_Bad_Is
then
2240 Error_Msg
-- CODEFIX
2241 ("|IS should be "";""", Scope
.Table
(Scope
.Last
+ 1).S_Is
);
2242 Set_Bad_Is_Detected
(Parent
, True);
2245 end Parse_Decls_Begin_End
;
2247 -------------------------
2248 -- Set_Loop_Block_Name --
2249 -------------------------
2251 function Set_Loop_Block_Name
(L
: Character) return Name_Id
is
2253 Name_Buffer
(1) := L
;
2254 Name_Buffer
(2) := '_';
2256 Loop_Block_Count
:= Loop_Block_Count
+ 1;
2257 Add_Nat_To_Name_Buffer
(Loop_Block_Count
);
2259 end Set_Loop_Block_Name
;
2265 procedure Then_Scan
is
2269 while Token
= Tok_Then
loop
2270 Error_Msg_SC
-- CODEFIX
2275 if Token
= Tok_And
or else Token
= Tok_Or
then
2276 Error_Msg_SC
("unexpected logical operator");
2277 Scan
; -- past logical operator
2279 if (Prev_Token
= Tok_And
and then Token
= Tok_Then
)
2281 (Prev_Token
= Tok_Or
and then Token
= Tok_Else
)
2286 Discard_Junk_Node
(P_Expression
);
2289 if Token
= Tok_Then
then