1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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
28 -- by RM section rather than alphabetical
33 -- Local functions, used only in this chapter
35 function P_Case_Statement
return Node_Id
;
36 function P_Case_Statement_Alternative
return Node_Id
;
37 function P_Condition
return Node_Id
;
38 function P_Exit_Statement
return Node_Id
;
39 function P_Goto_Statement
return Node_Id
;
40 function P_If_Statement
return Node_Id
;
41 function P_Label
return Node_Id
;
42 function P_Loop_Parameter_Specification
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_Loop_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
;
66 -- Parse loop statement. If Loop_Name is non-Empty on entry, it is
67 -- the N_Identifier node for the label on the loop. If Loop_Name is
68 -- Empty on entry (the default), then the loop statement is unlabeled.
70 function P_While_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
;
71 -- Parse while 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 while statement is unlabeled.
75 function Set_Loop_Block_Name
(L
: Character) return Name_Id
;
76 -- Given a letter 'L' for a loop or 'B' for a block, returns a name
77 -- of the form L_nn or B_nn where nn is a serial number obtained by
78 -- incrementing the variable Loop_Block_Count.
81 -- Scan past THEN token, testing for illegal junk after it
83 ---------------------------------
84 -- 5.1 Sequence of Statements --
85 ---------------------------------
87 -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT}
90 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
92 -- SIMPLE_STATEMENT ::= NULL_STATEMENT
93 -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT
94 -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT
95 -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT
96 -- | REQUEUE_STATEMENT | DELAY_STATEMENT
97 -- | ABORT_STATEMENT | RAISE_STATEMENT
100 -- COMPOUND_STATEMENT ::=
101 -- IF_STATEMENT | CASE_STATEMENT
102 -- | LOOP_STATEMENT | BLOCK_STATEMENT
103 -- | ACCEPT_STATEMENT | SELECT_STATEMENT
105 -- This procedure scans a sequence of statements. The caller sets SS_Flags
106 -- to indicate acceptable termination conditions for the sequence:
108 -- SS_Flags.Eftm Terminate on ELSIF
109 -- SS_Flags.Eltm Terminate on ELSE
110 -- SS_Flags.Extm Terminate on EXCEPTION
111 -- SS_Flags.Ortm Terminate on OR
112 -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return)
113 -- SS_Flags.Whtm Terminate on WHEN
114 -- SS_Flags.Unco Unconditional terminate after scanning one statement
116 -- In addition, the scan is always terminated by encountering END or the
117 -- end of file (EOF) condition. If one of the six above terminators is
118 -- encountered with the corresponding SS_Flags flag not set, then the
119 -- action taken is as follows:
121 -- If the keyword occurs to the left of the expected column of the end
122 -- for the current sequence (as recorded in the current end context),
123 -- then it is assumed to belong to an outer context, and is considered
124 -- to terminate the sequence of statements.
126 -- If the keyword occurs to the right of, or in the expected column of
127 -- the end for the current sequence, then an error message is output,
128 -- the keyword together with its associated context is skipped, and
129 -- the statement scan continues until another terminator is found.
131 -- Note that the first action means that control can return to the caller
132 -- with Token set to a terminator other than one of those specified by the
133 -- SS parameter. The caller should treat such a case as equivalent to END.
135 -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at
136 -- least one real statement (other than a pragma) is required in the
137 -- statement sequence. During the processing of the sequence, this
138 -- flag is manipulated to indicate the current status of the requirement
139 -- for a statement. For example, it is turned off by the occurrence of a
140 -- statement, and back on by a label (which requires a following statement)
142 -- Error recovery: cannot raise Error_Resync. If an error occurs during
143 -- parsing a statement, then the scan pointer is advanced past the next
144 -- semicolon and the parse continues.
146 function P_Sequence_Of_Statements
(SS_Flags
: SS_Rec
) return List_Id
is
148 Statement_Required
: Boolean;
149 -- This flag indicates if a subsequent statement (other than a pragma)
150 -- is required. It is initialized from the Sreq flag, and modified as
151 -- statements are scanned (a statement turns it off, and a label turns
152 -- it back on again since a statement must follow a label).
154 Declaration_Found
: Boolean := False;
155 -- This flag is set True if a declaration is encountered, so that the
156 -- error message about declarations in the statement part is only
157 -- given once for a given sequence of statements.
159 Scan_State_Label
: Saved_Scan_State
;
160 Scan_State
: Saved_Scan_State
;
162 Statement_List
: List_Id
;
163 Block_Label
: Name_Id
;
167 procedure Junk_Declaration
;
168 -- Procedure called to handle error of declaration encountered in
169 -- statement sequence.
171 procedure Test_Statement_Required
;
172 -- Flag error if Statement_Required flag set
174 ----------------------
175 -- Junk_Declaration --
176 ----------------------
178 procedure Junk_Declaration
is
180 if (not Declaration_Found
) or All_Errors_Mode
then
181 Error_Msg_SC
-- CODEFIX
182 ("declarations must come before BEGIN");
183 Declaration_Found
:= True;
186 Skip_Declaration
(Statement_List
);
187 end Junk_Declaration
;
189 -----------------------------
190 -- Test_Statement_Required --
191 -----------------------------
193 procedure Test_Statement_Required
is
195 if Statement_Required
then
196 Error_Msg_BC
("statement expected");
198 end Test_Statement_Required
;
200 -- Start of processing for P_Sequence_Of_Statements
203 Statement_List
:= New_List
;
204 Statement_Required
:= SS_Flags
.Sreq
;
207 Ignore
(Tok_Semicolon
);
211 Style
.Check_Indentation
;
214 -- Deal with reserved identifier (in assignment or call)
216 if Is_Reserved_Identifier
then
217 Save_Scan_State
(Scan_State
); -- at possible bad identifier
218 Scan
; -- and scan past it
220 -- We have an reserved word which is spelled in identifier
221 -- style, so the question is whether it really is intended
222 -- to be an identifier.
225 -- If followed by a semicolon, then it is an identifier,
226 -- with the exception of the cases tested for below.
228 (Token
= Tok_Semicolon
229 and then Prev_Token
/= Tok_Return
230 and then Prev_Token
/= Tok_Null
231 and then Prev_Token
/= Tok_Raise
232 and then Prev_Token
/= Tok_End
233 and then Prev_Token
/= Tok_Exit
)
235 -- If followed by colon, colon-equal, or dot, then we
236 -- definitely have an identifier (could not be reserved)
238 or else Token
= Tok_Colon
239 or else Token
= Tok_Colon_Equal
240 or else Token
= Tok_Dot
242 -- Left paren means we have an identifier except for those
243 -- reserved words that can legitimately be followed by a
247 (Token
= Tok_Left_Paren
248 and then Prev_Token
/= Tok_Case
249 and then Prev_Token
/= Tok_Delay
250 and then Prev_Token
/= Tok_If
251 and then Prev_Token
/= Tok_Elsif
252 and then Prev_Token
/= Tok_Return
253 and then Prev_Token
/= Tok_When
254 and then Prev_Token
/= Tok_While
255 and then Prev_Token
/= Tok_Separate
)
257 -- Here we have an apparent reserved identifier and the
258 -- token past it is appropriate to this usage (and would
259 -- be a definite error if this is not an identifier). What
260 -- we do is to use P_Identifier to fix up the identifier,
261 -- and then fall into the normal processing.
263 Restore_Scan_State
(Scan_State
); -- back to the ID
264 Scan_Reserved_Identifier
(Force_Msg
=> False);
266 -- Not a reserved identifier after all (or at least we can't
267 -- be sure that it is), so reset the scan and continue.
270 Restore_Scan_State
(Scan_State
); -- back to the reserved word
274 -- Now look to see what kind of statement we have
278 -- Case of end or EOF
280 when Tok_End | Tok_EOF
=>
282 -- These tokens always terminate the statement sequence
284 Test_Statement_Required
;
291 -- Terminate if Eftm set or if the ELSIF is to the left
292 -- of the expected column of the end for this sequence
295 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
297 Test_Statement_Required
;
300 -- Otherwise complain and skip past ELSIF Condition then
303 Error_Msg_SC
("ELSIF not allowed here");
305 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
307 Statement_Required
:= False;
314 -- Terminate if Eltm set or if the else is to the left
315 -- of the expected column of the end for this sequence
318 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
320 Test_Statement_Required
;
323 -- Otherwise complain and skip past else
326 Error_Msg_SC
("ELSE not allowed here");
328 Statement_Required
:= False;
333 when Tok_Exception
=>
334 Test_Statement_Required
;
336 -- If Extm not set and the exception is not to the left
337 -- of the expected column of the end for this sequence, then
338 -- we assume it belongs to the current sequence, even though
339 -- it is not permitted.
341 if not SS_Flags
.Extm
and then
342 Start_Column
>= Scope
.Table
(Scope
.Last
).Ecol
345 Error_Msg_SC
("exception handler not permitted here");
346 Scan
; -- past EXCEPTION
347 Discard_Junk_List
(Parse_Exception_Handlers
);
350 -- Always return, in the case where we scanned out handlers
351 -- that we did not expect, Parse_Exception_Handlers returned
352 -- with Token being either end or EOF, so we are OK
360 -- Terminate if Ortm set or if the or is to the left
361 -- of the expected column of the end for this sequence
364 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
366 Test_Statement_Required
;
369 -- Otherwise complain and skip past or
372 Error_Msg_SC
("OR not allowed here");
374 Statement_Required
:= False;
377 -- Case of THEN (deal also with THEN ABORT)
380 Save_Scan_State
(Scan_State
); -- at THEN
383 -- Terminate if THEN ABORT allowed (ATC case)
385 exit when SS_Flags
.Tatm
and then Token
= Tok_Abort
;
387 -- Otherwise we treat THEN as some kind of mess where we
388 -- did not see the associated IF, but we pick up assuming
389 -- it had been there!
391 Restore_Scan_State
(Scan_State
); -- to THEN
392 Append_To
(Statement_List
, P_If_Statement
);
393 Statement_Required
:= False;
395 -- Case of WHEN (error because we are not in a case)
397 when Tok_When | Tok_Others
=>
399 -- Terminate if Whtm set or if the WHEN is to the left
400 -- of the expected column of the end for this sequence
403 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
405 Test_Statement_Required
;
408 -- Otherwise complain and skip when Choice {| Choice} =>
411 Error_Msg_SC
("WHEN not allowed here");
413 Discard_Junk_List
(P_Discrete_Choice_List
);
415 Statement_Required
:= False;
418 -- Cases of statements starting with an identifier
420 when Tok_Identifier
=>
423 -- Save scan pointers and line number in case block label
425 Id_Node
:= Token_Node
;
426 Block_Label
:= Token_Name
;
427 Save_Scan_State
(Scan_State_Label
); -- at possible label
430 -- Check for common case of assignment, since it occurs
431 -- frequently, and we want to process it efficiently.
433 if Token
= Tok_Colon_Equal
then
434 Scan
; -- past the colon-equal
435 Append_To
(Statement_List
,
436 P_Assignment_Statement
(Id_Node
));
437 Statement_Required
:= False;
439 -- Check common case of procedure call, another case that
440 -- we want to speed up as much as possible.
442 elsif Token
= Tok_Semicolon
then
443 Append_To
(Statement_List
,
444 P_Statement_Name
(Id_Node
));
445 Scan
; -- past semicolon
446 Statement_Required
:= False;
448 -- Check for case of "go to" in place of "goto"
450 elsif Token
= Tok_Identifier
451 and then Block_Label
= Name_Go
452 and then Token_Name
= Name_To
454 Error_Msg_SP
-- CODEFIX
455 ("goto is one word");
456 Append_To
(Statement_List
, P_Goto_Statement
);
457 Statement_Required
:= False;
459 -- Check common case of = used instead of :=, just so we
460 -- give a better error message for this special misuse.
462 elsif Token
= Tok_Equal
then
463 T_Colon_Equal
; -- give := expected message
464 Append_To
(Statement_List
,
465 P_Assignment_Statement
(Id_Node
));
466 Statement_Required
:= False;
468 -- Check case of loop label or block label
470 elsif Token
= Tok_Colon
471 or else (Token
in Token_Class_Labeled_Stmt
472 and then not Token_Is_At_Start_Of_Line
)
474 T_Colon
; -- past colon (if there, or msg for missing one)
476 -- Test for more than one label
479 exit when Token
/= Tok_Identifier
;
480 Save_Scan_State
(Scan_State
); -- at second Id
483 if Token
= Tok_Colon
then
485 ("only one label allowed on block or loop");
486 Scan
; -- past colon on extra label
488 -- Use the second label as the "real" label
490 Scan_State_Label
:= Scan_State
;
492 -- We will set Error_name as the Block_Label since
493 -- we really don't know which of the labels might
494 -- be used at the end of the loop or block!
496 Block_Label
:= Error_Name
;
498 -- If Id with no colon, then backup to point to the
499 -- Id and we will issue the message below when we try
500 -- to scan out the statement as some other form.
503 Restore_Scan_State
(Scan_State
); -- to second Id
508 -- Loop_Statement (labeled Loop_Statement)
510 if Token
= Tok_Loop
then
511 Append_To
(Statement_List
,
512 P_Loop_Statement
(Id_Node
));
514 -- While statement (labeled loop statement with WHILE)
516 elsif Token
= Tok_While
then
517 Append_To
(Statement_List
,
518 P_While_Statement
(Id_Node
));
520 -- Declare statement (labeled block statement with
523 elsif Token
= Tok_Declare
then
524 Append_To
(Statement_List
,
525 P_Declare_Statement
(Id_Node
));
527 -- Begin statement (labeled block statement with no
530 elsif Token
= Tok_Begin
then
531 Append_To
(Statement_List
,
532 P_Begin_Statement
(Id_Node
));
534 -- For statement (labeled loop statement with FOR)
536 elsif Token
= Tok_For
then
537 Append_To
(Statement_List
,
538 P_For_Statement
(Id_Node
));
540 -- Improper statement follows label. If we have an
541 -- expression token, then assume the colon was part
542 -- of a misplaced declaration.
544 elsif Token
not in Token_Class_Eterm
then
545 Restore_Scan_State
(Scan_State_Label
);
548 -- Otherwise complain we have inappropriate statement
552 ("loop or block statement must follow label");
555 Statement_Required
:= False;
557 -- Here we have an identifier followed by something
558 -- other than a colon, semicolon or assignment symbol.
559 -- The only valid possibility is a name extension symbol
561 elsif Token
in Token_Class_Namext
then
562 Restore_Scan_State
(Scan_State_Label
); -- to Id
565 -- Skip junk right parens in this context
567 Ignore
(Tok_Right_Paren
);
569 -- Check context following call
571 if Token
= Tok_Colon_Equal
then
572 Scan
; -- past colon equal
573 Append_To
(Statement_List
,
574 P_Assignment_Statement
(Name_Node
));
575 Statement_Required
:= False;
577 -- Check common case of = used instead of :=
579 elsif Token
= Tok_Equal
then
580 T_Colon_Equal
; -- give := expected message
581 Append_To
(Statement_List
,
582 P_Assignment_Statement
(Name_Node
));
583 Statement_Required
:= False;
585 -- Check apostrophe cases
587 elsif Token
= Tok_Apostrophe
then
588 Append_To
(Statement_List
,
589 P_Code_Statement
(Name_Node
));
590 Statement_Required
:= False;
592 -- The only other valid item after a name is ; which
593 -- means that the item we just scanned was a call.
595 elsif Token
= Tok_Semicolon
then
596 Append_To
(Statement_List
,
597 P_Statement_Name
(Name_Node
));
598 Scan
; -- past semicolon
599 Statement_Required
:= False;
601 -- A slash following an identifier or a selected
602 -- component in this situation is most likely a period
603 -- (see location of keys on keyboard).
605 elsif Token
= Tok_Slash
606 and then (Nkind
(Name_Node
) = N_Identifier
608 Nkind
(Name_Node
) = N_Selected_Component
)
610 Error_Msg_SC
("""/"" should be "".""");
611 Statement_Required
:= False;
614 -- Else we have a missing semicolon
618 Statement_Required
:= False;
621 -- If junk after identifier, check if identifier is an
622 -- instance of an incorrectly spelled keyword. If so, we
623 -- do nothing. The Bad_Spelling_Of will have reset Token
624 -- to the appropriate keyword, so the next time round the
625 -- loop we will process the modified token. Note that we
626 -- check for ELSIF before ELSE here. That's not accidental.
627 -- We don't want to identify a misspelling of ELSE as
628 -- ELSIF, and in particular we do not want to treat ELSEIF
632 Restore_Scan_State
(Scan_State_Label
); -- to identifier
634 if Bad_Spelling_Of
(Tok_Abort
)
635 or else Bad_Spelling_Of
(Tok_Accept
)
636 or else Bad_Spelling_Of
(Tok_Case
)
637 or else Bad_Spelling_Of
(Tok_Declare
)
638 or else Bad_Spelling_Of
(Tok_Delay
)
639 or else Bad_Spelling_Of
(Tok_Elsif
)
640 or else Bad_Spelling_Of
(Tok_Else
)
641 or else Bad_Spelling_Of
(Tok_End
)
642 or else Bad_Spelling_Of
(Tok_Exception
)
643 or else Bad_Spelling_Of
(Tok_Exit
)
644 or else Bad_Spelling_Of
(Tok_For
)
645 or else Bad_Spelling_Of
(Tok_Goto
)
646 or else Bad_Spelling_Of
(Tok_If
)
647 or else Bad_Spelling_Of
(Tok_Loop
)
648 or else Bad_Spelling_Of
(Tok_Or
)
649 or else Bad_Spelling_Of
(Tok_Pragma
)
650 or else Bad_Spelling_Of
(Tok_Raise
)
651 or else Bad_Spelling_Of
(Tok_Requeue
)
652 or else Bad_Spelling_Of
(Tok_Return
)
653 or else Bad_Spelling_Of
(Tok_Select
)
654 or else Bad_Spelling_Of
(Tok_When
)
655 or else Bad_Spelling_Of
(Tok_While
)
659 -- If not a bad spelling, then we really have junk
662 Scan
; -- past identifier again
664 -- If next token is first token on line, then we
665 -- consider that we were missing a semicolon after
666 -- the identifier, and process it as a procedure
667 -- call with no parameters.
669 if Token_Is_At_Start_Of_Line
then
670 Append_To
(Statement_List
,
671 P_Statement_Name
(Id_Node
));
672 T_Semicolon
; -- to give error message
673 Statement_Required
:= False;
675 -- Otherwise we give a missing := message and
676 -- simply abandon the junk that is there now.
679 T_Colon_Equal
; -- give := expected message
686 -- Statement starting with operator symbol. This could be
687 -- a call, a name starting an assignment, or a qualified
690 when Tok_Operator_Symbol
=>
694 -- An attempt at a range attribute or a qualified expression
695 -- must be illegal here (a code statement cannot possibly
696 -- allow qualification by a function name).
698 if Token
= Tok_Apostrophe
then
699 Error_Msg_SC
("apostrophe illegal here");
703 -- Scan possible assignment if we have a name
705 if Expr_Form
= EF_Name
706 and then Token
= Tok_Colon_Equal
708 Scan
; -- past colon equal
709 Append_To
(Statement_List
,
710 P_Assignment_Statement
(Name_Node
));
712 Append_To
(Statement_List
,
713 P_Statement_Name
(Name_Node
));
717 Statement_Required
:= False;
719 -- Label starting with << which must precede real statement
721 when Tok_Less_Less
=>
722 Append_To
(Statement_List
, P_Label
);
723 Statement_Required
:= True;
725 -- Pragma appearing as a statement in a statement sequence
729 Append_To
(Statement_List
, P_Pragma
);
735 Append_To
(Statement_List
, P_Abort_Statement
);
736 Statement_Required
:= False;
742 Append_To
(Statement_List
, P_Accept_Statement
);
743 Statement_Required
:= False;
745 -- Begin_Statement (Block_Statement with no declare, no label)
749 Append_To
(Statement_List
, P_Begin_Statement
);
750 Statement_Required
:= False;
756 Append_To
(Statement_List
, P_Case_Statement
);
757 Statement_Required
:= False;
759 -- Block_Statement with DECLARE and no label
763 Append_To
(Statement_List
, P_Declare_Statement
);
764 Statement_Required
:= False;
770 Append_To
(Statement_List
, P_Delay_Statement
);
771 Statement_Required
:= False;
777 Append_To
(Statement_List
, P_Exit_Statement
);
778 Statement_Required
:= False;
780 -- Loop_Statement with FOR and no label
784 Append_To
(Statement_List
, P_For_Statement
);
785 Statement_Required
:= False;
791 Append_To
(Statement_List
, P_Goto_Statement
);
792 Statement_Required
:= False;
798 Append_To
(Statement_List
, P_If_Statement
);
799 Statement_Required
:= False;
805 Append_To
(Statement_List
, P_Loop_Statement
);
806 Statement_Required
:= False;
812 Append_To
(Statement_List
, P_Null_Statement
);
813 Statement_Required
:= False;
819 Append_To
(Statement_List
, P_Raise_Statement
);
820 Statement_Required
:= False;
826 Append_To
(Statement_List
, P_Requeue_Statement
);
827 Statement_Required
:= False;
833 Append_To
(Statement_List
, P_Return_Statement
);
834 Statement_Required
:= False;
840 Append_To
(Statement_List
, P_Select_Statement
);
841 Statement_Required
:= False;
843 -- While_Statement (Block_Statement with while and no loop)
847 Append_To
(Statement_List
, P_While_Statement
);
848 Statement_Required
:= False;
850 -- Anything else is some kind of junk, signal an error message
851 -- and then raise Error_Resync, to merge with the normal
852 -- handling of a bad statement.
856 if Token
in Token_Class_Declk
then
860 Error_Msg_BC
("statement expected");
865 -- On error resynchronization, skip past next semicolon, and, since
866 -- we are still in the statement loop, look for next statement. We
867 -- set Statement_Required False to avoid an unnecessary error message
868 -- complaining that no statement was found (i.e. we consider the
869 -- junk to satisfy the requirement for a statement being present).
873 Resync_Past_Semicolon_Or_To_Loop_Or_Then
;
874 Statement_Required
:= False;
877 exit when SS_Flags
.Unco
;
881 return Statement_List
;
883 end P_Sequence_Of_Statements
;
889 -- Parsed by P_Sequence_Of_Statements (5.1), except for the case
890 -- of a statement of the form of a name, which is handled here. The
891 -- argument passed in is the tree for the name which has been scanned
892 -- The returned value is the corresponding statement form.
894 -- This routine is also used by Par.Prag for processing the procedure
895 -- call that appears as the second argument of a pragma Assert.
897 -- Error recovery: cannot raise Error_Resync
899 function P_Statement_Name
(Name_Node
: Node_Id
) return Node_Id
is
903 -- Case of Indexed component, which is a procedure call with arguments
905 if Nkind
(Name_Node
) = N_Indexed_Component
then
907 Prefix_Node
: constant Node_Id
:= Prefix
(Name_Node
);
908 Exprs_Node
: constant List_Id
:= Expressions
(Name_Node
);
911 Change_Node
(Name_Node
, N_Procedure_Call_Statement
);
912 Set_Name
(Name_Node
, Prefix_Node
);
913 Set_Parameter_Associations
(Name_Node
, Exprs_Node
);
917 -- Case of function call node, which is a really a procedure call
919 elsif Nkind
(Name_Node
) = N_Function_Call
then
921 Fname_Node
: constant Node_Id
:= Name
(Name_Node
);
922 Params_List
: constant List_Id
:=
923 Parameter_Associations
(Name_Node
);
926 Change_Node
(Name_Node
, N_Procedure_Call_Statement
);
927 Set_Name
(Name_Node
, Fname_Node
);
928 Set_Parameter_Associations
(Name_Node
, Params_List
);
932 -- Case of call to attribute that denotes a procedure. Here we
933 -- just leave the attribute reference unchanged.
935 elsif Nkind
(Name_Node
) = N_Attribute_Reference
936 and then Is_Procedure_Attribute_Name
(Attribute_Name
(Name_Node
))
940 -- All other cases of names are parameterless procedure calls
944 New_Node
(N_Procedure_Call_Statement
, Sloc
(Name_Node
));
945 Set_Name
(Stmt_Node
, Name_Node
);
949 end P_Statement_Name
;
951 ---------------------------
952 -- 5.1 Simple Statement --
953 ---------------------------
955 -- Parsed by P_Sequence_Of_Statements (5.1)
957 -----------------------------
958 -- 5.1 Compound Statement --
959 -----------------------------
961 -- Parsed by P_Sequence_Of_Statements (5.1)
963 -------------------------
964 -- 5.1 Null Statement --
965 -------------------------
967 -- NULL_STATEMENT ::= null;
969 -- The caller has already checked that the current token is null
971 -- Error recovery: cannot raise Error_Resync
973 function P_Null_Statement
return Node_Id
is
974 Null_Stmt_Node
: Node_Id
;
977 Null_Stmt_Node
:= New_Node
(N_Null_Statement
, Token_Ptr
);
980 return Null_Stmt_Node
;
981 end P_Null_Statement
;
987 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
989 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
991 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
992 -- (not an OPERATOR_SYMBOL)
994 -- The caller has already checked that the current token is <<
996 -- Error recovery: can raise Error_Resync
998 function P_Label
return Node_Id
is
999 Label_Node
: Node_Id
;
1002 Label_Node
:= New_Node
(N_Label
, Token_Ptr
);
1004 Set_Identifier
(Label_Node
, P_Identifier
(C_Greater_Greater
));
1006 Append_Elmt
(Label_Node
, Label_List
);
1010 -------------------------------
1011 -- 5.1 Statement Identifier --
1012 -------------------------------
1014 -- Statement label is parsed by P_Label (5.1)
1016 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1017 -- or P_While_Statement (5.5)
1019 -- Block label is parsed by P_Begin_Statement (5.6) or
1020 -- P_Declare_Statement (5.6)
1022 -------------------------------
1023 -- 5.2 Assignment Statement --
1024 -------------------------------
1026 -- ASSIGNMENT_STATEMENT ::=
1027 -- variable_NAME := EXPRESSION;
1029 -- Error recovery: can raise Error_Resync
1031 function P_Assignment_Statement
(LHS
: Node_Id
) return Node_Id
is
1032 Assign_Node
: Node_Id
;
1035 Assign_Node
:= New_Node
(N_Assignment_Statement
, Prev_Token_Ptr
);
1036 Set_Name
(Assign_Node
, LHS
);
1037 Set_Expression
(Assign_Node
, P_Expression_No_Right_Paren
);
1040 end P_Assignment_Statement
;
1042 -----------------------
1043 -- 5.3 If Statement --
1044 -----------------------
1047 -- if CONDITION then
1048 -- SEQUENCE_OF_STATEMENTS
1049 -- {elsif CONDITION then
1050 -- SEQUENCE_OF_STATEMENTS}
1052 -- SEQUENCE_OF_STATEMENTS]
1055 -- The caller has checked that the initial token is IF (or in the error
1056 -- case of a mysterious THEN, the initial token may simply be THEN, in
1057 -- which case, no condition (or IF) was scanned).
1059 -- Error recovery: can raise Error_Resync
1061 function P_If_Statement
return Node_Id
is
1063 Elsif_Node
: Node_Id
;
1066 procedure Add_Elsif_Part
;
1067 -- An internal procedure used to scan out a single ELSIF part. On entry
1068 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1069 -- scanned out and is in Prev_Token.
1071 procedure Check_If_Column
;
1072 -- An internal procedure used to check that THEN, ELSE, or ELSIF
1073 -- appear in the right place if column checking is enabled (i.e. if
1074 -- they are the first token on the line, then they must appear in
1075 -- the same column as the opening IF).
1077 procedure Check_Then_Column
;
1078 -- This procedure carries out the style checks for a THEN token
1079 -- Note that the caller has set Loc to the Source_Ptr value for
1080 -- the previous IF or ELSIF token. These checks apply only to a
1081 -- THEN at the start of a line.
1083 function Else_Should_Be_Elsif
return Boolean;
1084 -- An internal routine used to do a special error recovery check when
1085 -- an ELSE is encountered. It determines if the ELSE should be treated
1086 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1087 -- is followed by a sequence of tokens, starting on the same line as
1088 -- the ELSE, which are not expression terminators, followed by a THEN.
1089 -- On entry, the ELSE has been scanned out.
1091 procedure Add_Elsif_Part
is
1093 if No
(Elsif_Parts
(If_Node
)) then
1094 Set_Elsif_Parts
(If_Node
, New_List
);
1097 Elsif_Node
:= New_Node
(N_Elsif_Part
, Prev_Token_Ptr
);
1098 Loc
:= Prev_Token_Ptr
;
1099 Set_Condition
(Elsif_Node
, P_Condition
);
1103 (Elsif_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1104 Append
(Elsif_Node
, Elsif_Parts
(If_Node
));
1107 procedure Check_If_Column
is
1109 if RM_Column_Check
and then Token_Is_At_Start_Of_Line
1110 and then Start_Column
/= Scope
.Table
(Scope
.Last
).Ecol
1112 Error_Msg_Col
:= Scope
.Table
(Scope
.Last
).Ecol
;
1113 Error_Msg_SC
("(style) this token should be@");
1115 end Check_If_Column
;
1117 procedure Check_Then_Column
is
1119 if Token_Is_At_Start_Of_Line
and then Token
= Tok_Then
then
1123 Style
.Check_Then
(Loc
);
1126 end Check_Then_Column
;
1128 function Else_Should_Be_Elsif
return Boolean is
1129 Scan_State
: Saved_Scan_State
;
1132 if Token_Is_At_Start_Of_Line
then
1136 Save_Scan_State
(Scan_State
);
1139 if Token
in Token_Class_Eterm
then
1140 Restore_Scan_State
(Scan_State
);
1143 Scan
; -- past non-expression terminating token
1145 if Token
= Tok_Then
then
1146 Restore_Scan_State
(Scan_State
);
1152 end Else_Should_Be_Elsif
;
1154 -- Start of processing for P_If_Statement
1157 If_Node
:= New_Node
(N_If_Statement
, Token_Ptr
);
1160 Scope
.Table
(Scope
.Last
).Etyp
:= E_If
;
1161 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1162 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1163 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
1164 Scope
.Table
(Scope
.Last
).Node
:= If_Node
;
1166 if Token
= Tok_If
then
1169 Set_Condition
(If_Node
, P_Condition
);
1171 -- Deal with misuse of IF expression => used instead
1172 -- of WHEN expression =>
1174 if Token
= Tok_Arrow
then
1175 Error_Msg_SC
("THEN expected");
1176 Scan
; -- past the arrow
1177 Pop_Scope_Stack
; -- remove unneeded entry
1184 Error_Msg_SC
("no IF for this THEN");
1185 Set_Condition
(If_Node
, Error
);
1191 (If_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1193 -- This loop scans out else and elsif parts
1196 if Token
= Tok_Elsif
then
1199 if Present
(Else_Statements
(If_Node
)) then
1200 Error_Msg_SP
("ELSIF cannot appear after ELSE");
1206 elsif Token
= Tok_Else
then
1210 if Else_Should_Be_Elsif
then
1211 Error_Msg_SP
("ELSE should be ELSIF");
1215 -- Here we have an else that really is an else
1217 if Present
(Else_Statements
(If_Node
)) then
1218 Error_Msg_SP
("only one ELSE part allowed");
1220 (P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
),
1221 Else_Statements
(If_Node
));
1224 (If_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1228 -- If anything other than ELSE or ELSIF, exit the loop. The token
1229 -- had better be END (and in fact it had better be END IF), but
1230 -- we will let End_Statements take care of checking that.
1242 --------------------
1244 --------------------
1246 -- CONDITION ::= boolean_EXPRESSION
1248 function P_Condition
return Node_Id
is
1252 Cond
:= P_Expression_No_Right_Paren
;
1254 -- It is never possible for := to follow a condition, so if we get
1255 -- a := we assume it is a mistyped equality. Note that we do not try
1256 -- to reconstruct the tree correctly in this case, but we do at least
1257 -- give an accurate error message.
1259 if Token
= Tok_Colon_Equal
then
1260 while Token
= Tok_Colon_Equal
loop
1261 Error_Msg_SC
(""":="" should be ""=""");
1262 Scan
; -- past junk :=
1263 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
1268 -- Otherwise check for redundant parens
1272 and then Paren_Count
(Cond
) > 0
1274 Style
.Check_Xtra_Parens
(First_Sloc
(Cond
));
1277 -- And return the result
1283 -------------------------
1284 -- 5.4 Case Statement --
1285 -------------------------
1287 -- CASE_STATEMENT ::=
1288 -- case EXPRESSION is
1289 -- CASE_STATEMENT_ALTERNATIVE
1290 -- {CASE_STATEMENT_ALTERNATIVE}
1293 -- The caller has checked that the first token is CASE
1295 -- Can raise Error_Resync
1297 function P_Case_Statement
return Node_Id
is
1298 Case_Node
: Node_Id
;
1299 Alternatives_List
: List_Id
;
1300 First_When_Loc
: Source_Ptr
;
1303 Case_Node
:= New_Node
(N_Case_Statement
, Token_Ptr
);
1306 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
1307 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1308 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1309 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
1310 Scope
.Table
(Scope
.Last
).Node
:= Case_Node
;
1313 Set_Expression
(Case_Node
, P_Expression_No_Right_Paren
);
1316 -- Prepare to parse case statement alternatives
1318 Alternatives_List
:= New_List
;
1319 P_Pragmas_Opt
(Alternatives_List
);
1320 First_When_Loc
:= Token_Ptr
;
1322 -- Loop through case statement alternatives
1325 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1326 -- that it is a semantic check to ensure the proper use of OTHERS
1328 if Token
= Tok_When
or else Token
= Tok_Others
then
1329 Append
(P_Case_Statement_Alternative
, Alternatives_List
);
1331 -- If we have an END, then probably we are at the end of the case
1332 -- but we only exit if Check_End thinks the END was reasonable.
1334 elsif Token
= Tok_End
then
1335 exit when Check_End
;
1337 -- Here if token is other than WHEN, OTHERS or END. We definitely
1338 -- have an error, but the question is whether or not to get out of
1339 -- the case statement. We don't want to get out early, or we will
1340 -- get a slew of junk error messages for subsequent when tokens.
1342 -- If the token is not at the start of the line, or if it is indented
1343 -- with respect to the current case statement, then the best guess is
1344 -- that we are still supposed to be inside the case statement. We
1345 -- complain about the missing WHEN, and discard the junk statements.
1347 elsif not Token_Is_At_Start_Of_Line
1348 or else Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
1350 Error_Msg_BC
("WHEN (case statement alternative) expected");
1352 -- Here is a possibility for infinite looping if we don't make
1353 -- progress. So try to process statements, otherwise exit
1356 Error_Ptr
: constant Source_Ptr
:= Scan_Ptr
;
1358 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Whtm
));
1359 exit when Scan_Ptr
= Error_Ptr
and then Check_End
;
1362 -- Here we have a junk token at the start of the line and it is
1363 -- not indented. If Check_End thinks there is a missing END, then
1364 -- we will get out of the case, otherwise we keep going.
1367 exit when Check_End
;
1371 -- Make sure we have at least one alternative
1373 if No
(First_Non_Pragma
(Alternatives_List
)) then
1375 ("WHEN expected, must have at least one alternative in case",
1380 Set_Alternatives
(Case_Node
, Alternatives_List
);
1383 end P_Case_Statement
;
1385 -------------------------------------
1386 -- 5.4 Case Statement Alternative --
1387 -------------------------------------
1389 -- CASE_STATEMENT_ALTERNATIVE ::=
1390 -- when DISCRETE_CHOICE_LIST =>
1391 -- SEQUENCE_OF_STATEMENTS
1393 -- The caller has checked that the initial token is WHEN or OTHERS
1394 -- Error recovery: can raise Error_Resync
1396 function P_Case_Statement_Alternative
return Node_Id
is
1397 Case_Alt_Node
: Node_Id
;
1401 Style
.Check_Indentation
;
1404 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Token_Ptr
);
1405 T_When
; -- past WHEN (or give error in OTHERS case)
1406 Set_Discrete_Choices
(Case_Alt_Node
, P_Discrete_Choice_List
);
1408 Set_Statements
(Case_Alt_Node
, P_Sequence_Of_Statements
(SS_Sreq_Whtm
));
1409 return Case_Alt_Node
;
1410 end P_Case_Statement_Alternative
;
1412 -------------------------
1413 -- 5.5 Loop Statement --
1414 -------------------------
1416 -- LOOP_STATEMENT ::=
1417 -- [LOOP_STATEMENT_IDENTIFIER:]
1418 -- [ITERATION_SCHEME] loop
1419 -- SEQUENCE_OF_STATEMENTS
1420 -- end loop [loop_IDENTIFIER];
1422 -- ITERATION_SCHEME ::=
1424 -- | for LOOP_PARAMETER_SPECIFICATION
1426 -- The parsing of loop statements is handled by one of three functions
1427 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1428 -- on the initial keyword in the construct (excluding the identifier)
1432 -- This function parses the case where no iteration scheme is present
1434 -- The caller has checked that the initial token is LOOP. The parameter
1435 -- is the node identifiers for the loop label if any (or is set to Empty
1436 -- if there is no loop label).
1438 -- Error recovery : cannot raise Error_Resync
1440 function P_Loop_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1441 Loop_Node
: Node_Id
;
1442 Created_Name
: Node_Id
;
1446 Scope
.Table
(Scope
.Last
).Labl
:= Loop_Name
;
1447 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1448 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1449 Scope
.Table
(Scope
.Last
).Etyp
:= E_Loop
;
1451 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1454 if No
(Loop_Name
) then
1456 Make_Identifier
(Sloc
(Loop_Node
),
1457 Chars
=> Set_Loop_Block_Name
('L'));
1458 Set_Comes_From_Source
(Created_Name
, False);
1459 Set_Has_Created_Identifier
(Loop_Node
, True);
1460 Set_Identifier
(Loop_Node
, Created_Name
);
1461 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1463 Set_Identifier
(Loop_Node
, Loop_Name
);
1466 Append_Elmt
(Loop_Node
, Label_List
);
1467 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1468 End_Statements
(Loop_Node
);
1470 end P_Loop_Statement
;
1474 -- This function parses a loop statement with a FOR iteration scheme
1476 -- The caller has checked that the initial token is FOR. The parameter
1477 -- is the node identifier for the block label if any (or is set to Empty
1478 -- if there is no block label).
1480 -- Note: the caller fills in the Identifier field if a label was present
1482 -- Error recovery: can raise Error_Resync
1484 function P_For_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1485 Loop_Node
: Node_Id
;
1486 Iter_Scheme_Node
: Node_Id
;
1487 Loop_For_Flag
: Boolean;
1488 Created_Name
: Node_Id
;
1492 Scope
.Table
(Scope
.Last
).Labl
:= Loop_Name
;
1493 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1494 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1495 Scope
.Table
(Scope
.Last
).Etyp
:= E_Loop
;
1497 Loop_For_Flag
:= (Prev_Token
= Tok_Loop
);
1499 Iter_Scheme_Node
:= New_Node
(N_Iteration_Scheme
, Token_Ptr
);
1500 Set_Loop_Parameter_Specification
1501 (Iter_Scheme_Node
, P_Loop_Parameter_Specification
);
1503 -- The following is a special test so that a miswritten for loop such
1504 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1505 -- entry in the scope stack. We don't bother to actually fix up the
1506 -- tree in this case since it's not worth the effort. Instead we just
1507 -- eat up the loop junk, leaving the entry for what now looks like an
1508 -- unmodified loop intact.
1510 if Loop_For_Flag
and then Token
= Tok_Semicolon
then
1511 Error_Msg_SC
("LOOP belongs here, not before FOR");
1518 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1520 if No
(Loop_Name
) then
1522 Make_Identifier
(Sloc
(Loop_Node
),
1523 Chars
=> Set_Loop_Block_Name
('L'));
1524 Set_Comes_From_Source
(Created_Name
, False);
1525 Set_Has_Created_Identifier
(Loop_Node
, True);
1526 Set_Identifier
(Loop_Node
, Created_Name
);
1527 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1529 Set_Identifier
(Loop_Node
, Loop_Name
);
1533 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1534 End_Statements
(Loop_Node
);
1535 Set_Iteration_Scheme
(Loop_Node
, Iter_Scheme_Node
);
1536 Append_Elmt
(Loop_Node
, Label_List
);
1539 end P_For_Statement
;
1541 -- P_While_Statement
1543 -- This procedure scans a loop statement with a WHILE iteration scheme
1545 -- The caller has checked that the initial token is WHILE. The parameter
1546 -- is the node identifier for the block label if any (or is set to Empty
1547 -- if there is no block label).
1549 -- Error recovery: cannot raise Error_Resync
1551 function P_While_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1552 Loop_Node
: Node_Id
;
1553 Iter_Scheme_Node
: Node_Id
;
1554 Loop_While_Flag
: Boolean;
1555 Created_Name
: Node_Id
;
1559 Scope
.Table
(Scope
.Last
).Labl
:= Loop_Name
;
1560 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1561 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1562 Scope
.Table
(Scope
.Last
).Etyp
:= E_Loop
;
1564 Loop_While_Flag
:= (Prev_Token
= Tok_Loop
);
1565 Iter_Scheme_Node
:= New_Node
(N_Iteration_Scheme
, Token_Ptr
);
1567 Set_Condition
(Iter_Scheme_Node
, P_Condition
);
1569 -- The following is a special test so that a miswritten for loop such
1570 -- as "loop while I > 10;" is handled nicely, without making an extra
1571 -- entry in the scope stack. We don't bother to actually fix up the
1572 -- tree in this case since it's not worth the effort. Instead we just
1573 -- eat up the loop junk, leaving the entry for what now looks like an
1574 -- unmodified loop intact.
1576 if Loop_While_Flag
and then Token
= Tok_Semicolon
then
1577 Error_Msg_SC
("LOOP belongs here, not before WHILE");
1584 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1587 if No
(Loop_Name
) then
1589 Make_Identifier
(Sloc
(Loop_Node
),
1590 Chars
=> Set_Loop_Block_Name
('L'));
1591 Set_Comes_From_Source
(Created_Name
, False);
1592 Set_Has_Created_Identifier
(Loop_Node
, True);
1593 Set_Identifier
(Loop_Node
, Created_Name
);
1594 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1596 Set_Identifier
(Loop_Node
, Loop_Name
);
1599 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1600 End_Statements
(Loop_Node
);
1601 Set_Iteration_Scheme
(Loop_Node
, Iter_Scheme_Node
);
1602 Append_Elmt
(Loop_Node
, Label_List
);
1605 end P_While_Statement
;
1607 ---------------------------------------
1608 -- 5.5 Loop Parameter Specification --
1609 ---------------------------------------
1611 -- LOOP_PARAMETER_SPECIFICATION ::=
1612 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1614 -- Error recovery: cannot raise Error_Resync
1616 function P_Loop_Parameter_Specification
return Node_Id
is
1617 Loop_Param_Specification_Node
: Node_Id
;
1620 Scan_State
: Saved_Scan_State
;
1623 Loop_Param_Specification_Node
:=
1624 New_Node
(N_Loop_Parameter_Specification
, Token_Ptr
);
1626 Save_Scan_State
(Scan_State
);
1627 ID_Node
:= P_Defining_Identifier
(C_In
);
1628 Set_Defining_Identifier
(Loop_Param_Specification_Node
, ID_Node
);
1630 if Token
= Tok_Left_Paren
then
1631 Error_Msg_SC
("subscripted loop parameter not allowed");
1632 Restore_Scan_State
(Scan_State
);
1633 Discard_Junk_Node
(P_Name
);
1635 elsif Token
= Tok_Dot
then
1636 Error_Msg_SC
("selected loop parameter not allowed");
1637 Restore_Scan_State
(Scan_State
);
1638 Discard_Junk_Node
(P_Name
);
1643 if Token
= Tok_Reverse
then
1644 Scan
; -- past REVERSE
1645 Set_Reverse_Present
(Loop_Param_Specification_Node
, True);
1648 Set_Discrete_Subtype_Definition
1649 (Loop_Param_Specification_Node
, P_Discrete_Subtype_Definition
);
1650 return Loop_Param_Specification_Node
;
1653 when Error_Resync
=>
1655 end P_Loop_Parameter_Specification
;
1657 --------------------------
1658 -- 5.6 Block Statement --
1659 --------------------------
1661 -- BLOCK_STATEMENT ::=
1662 -- [block_STATEMENT_IDENTIFIER:]
1664 -- DECLARATIVE_PART]
1666 -- HANDLED_SEQUENCE_OF_STATEMENTS
1667 -- end [block_IDENTIFIER];
1669 -- The parsing of block statements is handled by one of the two functions
1670 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1671 -- a declare section is present
1673 -- P_Declare_Statement
1675 -- This function parses a block statement with DECLARE present
1677 -- The caller has checked that the initial token is DECLARE
1679 -- Error recovery: cannot raise Error_Resync
1681 function P_Declare_Statement
1682 (Block_Name
: Node_Id
:= Empty
)
1685 Block_Node
: Node_Id
;
1686 Created_Name
: Node_Id
;
1689 Block_Node
:= New_Node
(N_Block_Statement
, Token_Ptr
);
1692 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
1693 Scope
.Table
(Scope
.Last
).Lreq
:= Present
(Block_Name
);
1694 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1695 Scope
.Table
(Scope
.Last
).Labl
:= Block_Name
;
1696 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1698 Scan
; -- past DECLARE
1700 if No
(Block_Name
) then
1702 Make_Identifier
(Sloc
(Block_Node
),
1703 Chars
=> Set_Loop_Block_Name
('B'));
1704 Set_Comes_From_Source
(Created_Name
, False);
1705 Set_Has_Created_Identifier
(Block_Node
, True);
1706 Set_Identifier
(Block_Node
, Created_Name
);
1707 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1709 Set_Identifier
(Block_Node
, Block_Name
);
1712 Append_Elmt
(Block_Node
, Label_List
);
1713 Parse_Decls_Begin_End
(Block_Node
);
1715 end P_Declare_Statement
;
1717 -- P_Begin_Statement
1719 -- This function parses a block statement with no DECLARE present
1721 -- The caller has checked that the initial token is BEGIN
1723 -- Error recovery: cannot raise Error_Resync
1725 function P_Begin_Statement
1726 (Block_Name
: Node_Id
:= Empty
)
1729 Block_Node
: Node_Id
;
1730 Created_Name
: Node_Id
;
1733 Block_Node
:= New_Node
(N_Block_Statement
, Token_Ptr
);
1736 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
1737 Scope
.Table
(Scope
.Last
).Lreq
:= Present
(Block_Name
);
1738 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1739 Scope
.Table
(Scope
.Last
).Labl
:= Block_Name
;
1740 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1742 if No
(Block_Name
) then
1744 Make_Identifier
(Sloc
(Block_Node
),
1745 Chars
=> Set_Loop_Block_Name
('B'));
1746 Set_Comes_From_Source
(Created_Name
, False);
1747 Set_Has_Created_Identifier
(Block_Node
, True);
1748 Set_Identifier
(Block_Node
, Created_Name
);
1749 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1751 Set_Identifier
(Block_Node
, Block_Name
);
1754 Append_Elmt
(Block_Node
, Label_List
);
1756 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1757 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1759 Set_Handled_Statement_Sequence
1760 (Block_Node
, P_Handled_Sequence_Of_Statements
);
1761 End_Statements
(Handled_Statement_Sequence
(Block_Node
));
1763 end P_Begin_Statement
;
1765 -------------------------
1766 -- 5.7 Exit Statement --
1767 -------------------------
1769 -- EXIT_STATEMENT ::=
1770 -- exit [loop_NAME] [when CONDITION];
1772 -- The caller has checked that the initial token is EXIT
1774 -- Error recovery: can raise Error_Resync
1776 function P_Exit_Statement
return Node_Id
is
1777 Exit_Node
: Node_Id
;
1779 function Missing_Semicolon_On_Exit
return Boolean;
1780 -- This function deals with the following specialized situation
1783 -- exit [identifier]
1786 -- This looks like a messed up EXIT WHEN, when in fact the problem
1787 -- is a missing semicolon. It is called with Token pointing to the
1788 -- WHEN token, and returns True if a semicolon is missing before
1789 -- the WHEN as in the above example.
1791 -------------------------------
1792 -- Missing_Semicolon_On_Exit --
1793 -------------------------------
1795 function Missing_Semicolon_On_Exit
return Boolean is
1796 State
: Saved_Scan_State
;
1799 if not Token_Is_At_Start_Of_Line
then
1802 elsif Scope
.Table
(Scope
.Last
).Etyp
/= E_Case
then
1806 Save_Scan_State
(State
);
1808 Scan
; -- past token after WHEN
1810 if Token
= Tok_Arrow
then
1811 Restore_Scan_State
(State
);
1814 Restore_Scan_State
(State
);
1818 end Missing_Semicolon_On_Exit
;
1820 -- Start of processing for P_Exit_Statement
1823 Exit_Node
:= New_Node
(N_Exit_Statement
, Token_Ptr
);
1826 if Token
= Tok_Identifier
then
1827 Set_Name
(Exit_Node
, P_Qualified_Simple_Name
);
1829 elsif Style_Check
then
1830 -- This EXIT has no name, so check that
1831 -- the innermost loop is unnamed too.
1833 Check_No_Exit_Name
:
1834 for J
in reverse 1 .. Scope
.Last
loop
1835 if Scope
.Table
(J
).Etyp
= E_Loop
then
1836 if Present
(Scope
.Table
(J
).Labl
)
1837 and then Comes_From_Source
(Scope
.Table
(J
).Labl
)
1839 -- Innermost loop in fact had a name, style check fails
1841 Style
.No_Exit_Name
(Scope
.Table
(J
).Labl
);
1844 exit Check_No_Exit_Name
;
1846 end loop Check_No_Exit_Name
;
1849 if Token
= Tok_When
and then not Missing_Semicolon_On_Exit
then
1851 Set_Condition
(Exit_Node
, P_Condition
);
1853 -- Allow IF instead of WHEN, giving error message
1855 elsif Token
= Tok_If
then
1857 Scan
; -- past IF used in place of WHEN
1858 Set_Condition
(Exit_Node
, P_Expression_No_Right_Paren
);
1863 end P_Exit_Statement
;
1865 -------------------------
1866 -- 5.8 Goto Statement --
1867 -------------------------
1869 -- GOTO_STATEMENT ::= goto label_NAME;
1871 -- The caller has checked that the initial token is GOTO (or TO in the
1872 -- error case where GO and TO were incorrectly separated).
1874 -- Error recovery: can raise Error_Resync
1876 function P_Goto_Statement
return Node_Id
is
1877 Goto_Node
: Node_Id
;
1880 Goto_Node
:= New_Node
(N_Goto_Statement
, Token_Ptr
);
1881 Scan
; -- past GOTO (or TO)
1882 Set_Name
(Goto_Node
, P_Qualified_Simple_Name_Resync
);
1883 Append_Elmt
(Goto_Node
, Goto_List
);
1887 end P_Goto_Statement
;
1889 ---------------------------
1890 -- Parse_Decls_Begin_End --
1891 ---------------------------
1893 -- This function parses the construct:
1897 -- HANDLED_SEQUENCE_OF_STATEMENTS
1900 -- The caller has built the scope stack entry, and created the node to
1901 -- whose Declarations and Handled_Statement_Sequence fields are to be
1902 -- set. On return these fields are filled in (except in the case of a
1903 -- task body, where the handled statement sequence is optional, and may
1904 -- thus be Empty), and the scan is positioned past the End sequence.
1906 -- If the BEGIN is missing, then the parent node is used to help construct
1907 -- an appropriate missing BEGIN message. Possibilities for the parent are:
1909 -- N_Block_Statement declare block
1910 -- N_Entry_Body entry body
1911 -- N_Package_Body package body (begin part optional)
1912 -- N_Subprogram_Body procedure or function body
1913 -- N_Task_Body task body
1915 -- Note: in the case of a block statement, there is definitely a DECLARE
1916 -- present (because a Begin statement without a DECLARE is handled by the
1917 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
1919 -- Error recovery: cannot raise Error_Resync
1921 procedure Parse_Decls_Begin_End
(Parent
: Node_Id
) is
1922 Body_Decl
: Node_Id
;
1923 Body_Sloc
: Source_Ptr
;
1926 Parent_Nkind
: Node_Kind
;
1927 Spec_Node
: Node_Id
;
1930 procedure Missing_Begin
(Msg
: String);
1931 -- Called to post a missing begin message. In the normal case this is
1932 -- posted at the start of the current token. A special case arises when
1933 -- P_Declarative_Items has previously found a missing begin, in which
1934 -- case we replace the original error message.
1936 procedure Set_Null_HSS
(Parent
: Node_Id
);
1937 -- Construct an empty handled statement sequence and install in Parent
1938 -- Leaves HSS set to reference the newly constructed statement sequence.
1944 procedure Missing_Begin
(Msg
: String) is
1946 if Missing_Begin_Msg
= No_Error_Msg
then
1949 Change_Error_Text
(Missing_Begin_Msg
, Msg
);
1951 -- Purge any messages issued after than, since a missing begin
1952 -- can cause a lot of havoc, and it is better not to dump these
1953 -- cascaded messages on the user.
1955 Purge_Messages
(Get_Location
(Missing_Begin_Msg
), Prev_Token_Ptr
);
1963 procedure Set_Null_HSS
(Parent
: Node_Id
) is
1968 Make_Null_Statement
(Token_Ptr
);
1969 Set_Comes_From_Source
(Null_Stm
, False);
1972 Make_Handled_Sequence_Of_Statements
(Token_Ptr
,
1973 Statements
=> New_List
(Null_Stm
));
1974 Set_Comes_From_Source
(HSS
, False);
1976 Set_Handled_Statement_Sequence
(Parent
, HSS
);
1979 -- Start of processing for Parse_Decls_Begin_End
1982 Decls
:= P_Declarative_Part
;
1984 -- Check for misplacement of later vs basic declarations in Ada 83
1986 if Ada_Version
= Ada_83
then
1987 Decl
:= First
(Decls
);
1989 -- Loop through sequence of basic declarative items
1991 Outer
: while Present
(Decl
) loop
1992 if Nkind
(Decl
) /= N_Subprogram_Body
1993 and then Nkind
(Decl
) /= N_Package_Body
1994 and then Nkind
(Decl
) /= N_Task_Body
1995 and then Nkind
(Decl
) not in N_Body_Stub
1999 -- Once a body is encountered, we only allow later declarative
2000 -- items. The inner loop checks the rest of the list.
2003 Body_Sloc
:= Sloc
(Decl
);
2005 Inner
: while Present
(Decl
) loop
2006 if Nkind
(Decl
) not in N_Later_Decl_Item
2007 and then Nkind
(Decl
) /= N_Pragma
2009 if Ada_Version
= Ada_83
then
2010 Error_Msg_Sloc
:= Body_Sloc
;
2012 ("(Ada 83) decl cannot appear after body#", Decl
);
2022 -- Here is where we deal with the case of IS used instead of semicolon.
2023 -- Specifically, if the last declaration in the declarative part is a
2024 -- subprogram body still marked as having a bad IS, then this is where
2025 -- we decide that the IS should really have been a semicolon and that
2026 -- the body should have been a declaration. Note that if the bad IS
2027 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2028 -- then the Bad_Is_Detected flag would have been reset by now.
2030 Body_Decl
:= Last
(Decls
);
2032 if Present
(Body_Decl
)
2033 and then Nkind
(Body_Decl
) = N_Subprogram_Body
2034 and then Bad_Is_Detected
(Body_Decl
)
2036 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2037 -- What we have now is a subprogram body with attached declarations
2038 -- and a possible statement sequence.
2040 -- First step is to take the declarations that were part of the bogus
2041 -- subprogram body and append them to the outer declaration chain.
2042 -- In other words we append them past the body (which we will later
2043 -- convert into a declaration).
2045 Append_List
(Declarations
(Body_Decl
), Decls
);
2047 -- Now take the handled statement sequence of the bogus body and
2048 -- set it as the statement sequence for the outer construct. Note
2049 -- that it may be empty (we specially allowed a missing BEGIN for
2050 -- a subprogram body marked as having a bad IS -- see below).
2052 Set_Handled_Statement_Sequence
(Parent
,
2053 Handled_Statement_Sequence
(Body_Decl
));
2055 -- Next step is to convert the old body node to a declaration node
2057 Spec_Node
:= Specification
(Body_Decl
);
2058 Change_Node
(Body_Decl
, N_Subprogram_Declaration
);
2059 Set_Specification
(Body_Decl
, Spec_Node
);
2061 -- Final step is to put the declarations for the parent where
2062 -- they belong, and then fall through the IF to scan out the
2065 Set_Declarations
(Parent
, Decls
);
2067 -- This is the normal case (i.e. any case except the bad IS case)
2068 -- If we have a BEGIN, then scan out the sequence of statements, and
2069 -- also reset the expected column for the END to match the BEGIN.
2072 Set_Declarations
(Parent
, Decls
);
2074 if Token
= Tok_Begin
then
2076 Style
.Check_Indentation
;
2079 Error_Msg_Col
:= Scope
.Table
(Scope
.Last
).Ecol
;
2082 and then Token_Is_At_Start_Of_Line
2083 and then Start_Column
/= Error_Msg_Col
2085 Error_Msg_SC
("(style) BEGIN in wrong column, should be@");
2088 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
2091 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
2093 Set_Handled_Statement_Sequence
(Parent
,
2094 P_Handled_Sequence_Of_Statements
);
2099 Parent_Nkind
:= Nkind
(Parent
);
2101 -- A special check for the missing IS case. If we have a
2102 -- subprogram body that was marked as having a suspicious
2103 -- IS, and the current token is END, then we simply confirm
2104 -- the suspicion, and do not require a BEGIN to be present
2106 if Parent_Nkind
= N_Subprogram_Body
2107 and then Token
= Tok_End
2108 and then Scope
.Table
(Scope
.Last
).Etyp
= E_Suspicious_Is
2110 Scope
.Table
(Scope
.Last
).Etyp
:= E_Bad_Is
;
2112 -- Otherwise BEGIN is not required for a package body, so we
2113 -- don't mind if it is missing, but we do construct a dummy
2114 -- one (so that we have somewhere to set End_Label).
2116 -- However if we have something other than a BEGIN which
2117 -- looks like it might be statements, then we signal a missing
2118 -- BEGIN for these cases as well. We define "something which
2119 -- looks like it might be statements" as a token other than
2120 -- END, EOF, or a token which starts declarations.
2122 elsif Parent_Nkind
= N_Package_Body
2123 and then (Token
= Tok_End
2124 or else Token
= Tok_EOF
2125 or else Token
in Token_Class_Declk
)
2127 Set_Null_HSS
(Parent
);
2129 -- These are cases in which a BEGIN is required and not present
2132 Set_Null_HSS
(Parent
);
2134 -- Prepare to issue error message
2136 Error_Msg_Sloc
:= Scope
.Table
(Scope
.Last
).Sloc
;
2137 Error_Msg_Node_1
:= Scope
.Table
(Scope
.Last
).Labl
;
2139 -- Now issue appropriate message
2141 if Parent_Nkind
= N_Block_Statement
then
2142 Missing_Begin
("missing BEGIN for DECLARE#!");
2144 elsif Parent_Nkind
= N_Entry_Body
then
2145 Missing_Begin
("missing BEGIN for ENTRY#!");
2147 elsif Parent_Nkind
= N_Subprogram_Body
then
2148 if Nkind
(Specification
(Parent
))
2149 = N_Function_Specification
2151 Missing_Begin
("missing BEGIN for function&#!");
2153 Missing_Begin
("missing BEGIN for procedure&#!");
2156 -- The case for package body arises only when
2157 -- we have possible statement junk present.
2159 elsif Parent_Nkind
= N_Package_Body
then
2160 Missing_Begin
("missing BEGIN for package body&#!");
2163 pragma Assert
(Parent_Nkind
= N_Task_Body
);
2164 Missing_Begin
("missing BEGIN for task body&#!");
2167 -- Here we pick up the statements after the BEGIN that
2168 -- should have been present but was not. We don't insist
2169 -- on statements being present if P_Declarative_Part had
2170 -- already found a missing BEGIN, since it might have
2171 -- swallowed a lone statement into the declarative part.
2173 if Missing_Begin_Msg
/= No_Error_Msg
2174 and then Token
= Tok_End
2178 Set_Handled_Statement_Sequence
(Parent
,
2179 P_Handled_Sequence_Of_Statements
);
2185 -- Here with declarations and handled statement sequence scanned
2187 if Present
(Handled_Statement_Sequence
(Parent
)) then
2188 End_Statements
(Handled_Statement_Sequence
(Parent
));
2193 -- We know that End_Statements removed an entry from the scope stack
2194 -- (because it is required to do so under all circumstances). We can
2195 -- therefore reference the entry it removed one past the stack top.
2196 -- What we are interested in is whether it was a case of a bad IS.
2198 if Scope
.Table
(Scope
.Last
+ 1).Etyp
= E_Bad_Is
then
2199 Error_Msg
("|IS should be "";""", Scope
.Table
(Scope
.Last
+ 1).S_Is
);
2200 Set_Bad_Is_Detected
(Parent
, True);
2203 end Parse_Decls_Begin_End
;
2205 -------------------------
2206 -- Set_Loop_Block_Name --
2207 -------------------------
2209 function Set_Loop_Block_Name
(L
: Character) return Name_Id
is
2211 Name_Buffer
(1) := L
;
2212 Name_Buffer
(2) := '_';
2214 Loop_Block_Count
:= Loop_Block_Count
+ 1;
2215 Add_Nat_To_Name_Buffer
(Loop_Block_Count
);
2217 end Set_Loop_Block_Name
;
2223 procedure Then_Scan
is
2227 while Token
= Tok_Then
loop
2228 Error_Msg_SC
("redundant THEN");
2232 if Token
= Tok_And
or else Token
= Tok_Or
then
2233 Error_Msg_SC
("unexpected logical operator");
2234 Scan
; -- past logical operator
2236 if (Prev_Token
= Tok_And
and then Token
= Tok_Then
)
2238 (Prev_Token
= Tok_Or
and then Token
= Tok_Else
)
2243 Discard_Junk_Node
(P_Expression
);
2246 if Token
= Tok_Then
then