1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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
-- CODEFIX
197 ("statement expected");
199 end Test_Statement_Required
;
201 -- Start of processing for P_Sequence_Of_Statements
204 Statement_List
:= New_List
;
205 Statement_Required
:= SS_Flags
.Sreq
;
208 Ignore
(Tok_Semicolon
);
212 Style
.Check_Indentation
;
215 -- Deal with reserved identifier (in assignment or call)
217 if Is_Reserved_Identifier
then
218 Save_Scan_State
(Scan_State
); -- at possible bad identifier
219 Scan
; -- and scan past it
221 -- We have an reserved word which is spelled in identifier
222 -- style, so the question is whether it really is intended
223 -- to be an identifier.
226 -- If followed by a semicolon, then it is an identifier,
227 -- with the exception of the cases tested for below.
229 (Token
= Tok_Semicolon
230 and then Prev_Token
/= Tok_Return
231 and then Prev_Token
/= Tok_Null
232 and then Prev_Token
/= Tok_Raise
233 and then Prev_Token
/= Tok_End
234 and then Prev_Token
/= Tok_Exit
)
236 -- If followed by colon, colon-equal, or dot, then we
237 -- definitely have an identifier (could not be reserved)
239 or else Token
= Tok_Colon
240 or else Token
= Tok_Colon_Equal
241 or else Token
= Tok_Dot
243 -- Left paren means we have an identifier except for those
244 -- reserved words that can legitimately be followed by a
248 (Token
= Tok_Left_Paren
249 and then Prev_Token
/= Tok_Case
250 and then Prev_Token
/= Tok_Delay
251 and then Prev_Token
/= Tok_If
252 and then Prev_Token
/= Tok_Elsif
253 and then Prev_Token
/= Tok_Return
254 and then Prev_Token
/= Tok_When
255 and then Prev_Token
/= Tok_While
256 and then Prev_Token
/= Tok_Separate
)
258 -- Here we have an apparent reserved identifier and the
259 -- token past it is appropriate to this usage (and would
260 -- be a definite error if this is not an identifier). What
261 -- we do is to use P_Identifier to fix up the identifier,
262 -- and then fall into the normal processing.
264 Restore_Scan_State
(Scan_State
); -- back to the ID
265 Scan_Reserved_Identifier
(Force_Msg
=> False);
267 -- Not a reserved identifier after all (or at least we can't
268 -- be sure that it is), so reset the scan and continue.
271 Restore_Scan_State
(Scan_State
); -- back to the reserved word
275 -- Now look to see what kind of statement we have
279 -- Case of end or EOF
281 when Tok_End | Tok_EOF
=>
283 -- These tokens always terminate the statement sequence
285 Test_Statement_Required
;
292 -- Terminate if Eftm set or if the ELSIF is to the left
293 -- of the expected column of the end for this sequence
296 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
298 Test_Statement_Required
;
301 -- Otherwise complain and skip past ELSIF Condition then
304 Error_Msg_SC
("ELSIF not allowed here");
306 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
308 Statement_Required
:= False;
315 -- Terminate if Eltm set or if the else is to the left
316 -- of the expected column of the end for this sequence
319 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
321 Test_Statement_Required
;
324 -- Otherwise complain and skip past else
327 Error_Msg_SC
("ELSE not allowed here");
329 Statement_Required
:= False;
334 when Tok_Exception
=>
335 Test_Statement_Required
;
337 -- If Extm not set and the exception is not to the left
338 -- of the expected column of the end for this sequence, then
339 -- we assume it belongs to the current sequence, even though
340 -- it is not permitted.
342 if not SS_Flags
.Extm
and then
343 Start_Column
>= Scope
.Table
(Scope
.Last
).Ecol
346 Error_Msg_SC
("exception handler not permitted here");
347 Scan
; -- past EXCEPTION
348 Discard_Junk_List
(Parse_Exception_Handlers
);
351 -- Always return, in the case where we scanned out handlers
352 -- that we did not expect, Parse_Exception_Handlers returned
353 -- with Token being either end or EOF, so we are OK
361 -- Terminate if Ortm set or if the or is to the left
362 -- of the expected column of the end for this sequence
365 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
367 Test_Statement_Required
;
370 -- Otherwise complain and skip past or
373 Error_Msg_SC
("OR not allowed here");
375 Statement_Required
:= False;
378 -- Case of THEN (deal also with THEN ABORT)
381 Save_Scan_State
(Scan_State
); -- at THEN
384 -- Terminate if THEN ABORT allowed (ATC case)
386 exit when SS_Flags
.Tatm
and then Token
= Tok_Abort
;
388 -- Otherwise we treat THEN as some kind of mess where we
389 -- did not see the associated IF, but we pick up assuming
390 -- it had been there!
392 Restore_Scan_State
(Scan_State
); -- to THEN
393 Append_To
(Statement_List
, P_If_Statement
);
394 Statement_Required
:= False;
396 -- Case of WHEN (error because we are not in a case)
398 when Tok_When | Tok_Others
=>
400 -- Terminate if Whtm set or if the WHEN is to the left
401 -- of the expected column of the end for this sequence
404 or else Start_Column
< Scope
.Table
(Scope
.Last
).Ecol
406 Test_Statement_Required
;
409 -- Otherwise complain and skip when Choice {| Choice} =>
412 Error_Msg_SC
("WHEN not allowed here");
414 Discard_Junk_List
(P_Discrete_Choice_List
);
416 Statement_Required
:= False;
419 -- Cases of statements starting with an identifier
421 when Tok_Identifier
=>
424 -- Save scan pointers and line number in case block label
426 Id_Node
:= Token_Node
;
427 Block_Label
:= Token_Name
;
428 Save_Scan_State
(Scan_State_Label
); -- at possible label
431 -- Check for common case of assignment, since it occurs
432 -- frequently, and we want to process it efficiently.
434 if Token
= Tok_Colon_Equal
then
435 Scan
; -- past the colon-equal
436 Append_To
(Statement_List
,
437 P_Assignment_Statement
(Id_Node
));
438 Statement_Required
:= False;
440 -- Check common case of procedure call, another case that
441 -- we want to speed up as much as possible.
443 elsif Token
= Tok_Semicolon
then
444 Append_To
(Statement_List
,
445 P_Statement_Name
(Id_Node
));
446 Scan
; -- past semicolon
447 Statement_Required
:= False;
449 -- Check for case of "go to" in place of "goto"
451 elsif Token
= Tok_Identifier
452 and then Block_Label
= Name_Go
453 and then Token_Name
= Name_To
455 Error_Msg_SP
-- CODEFIX
456 ("goto is one word");
457 Append_To
(Statement_List
, P_Goto_Statement
);
458 Statement_Required
:= False;
460 -- Check common case of = used instead of :=, just so we
461 -- give a better error message for this special misuse.
463 elsif Token
= Tok_Equal
then
464 T_Colon_Equal
; -- give := expected message
465 Append_To
(Statement_List
,
466 P_Assignment_Statement
(Id_Node
));
467 Statement_Required
:= False;
469 -- Check case of loop label or block label
471 elsif Token
= Tok_Colon
472 or else (Token
in Token_Class_Labeled_Stmt
473 and then not Token_Is_At_Start_Of_Line
)
475 T_Colon
; -- past colon (if there, or msg for missing one)
477 -- Test for more than one label
480 exit when Token
/= Tok_Identifier
;
481 Save_Scan_State
(Scan_State
); -- at second Id
484 if Token
= Tok_Colon
then
486 ("only one label allowed on block or loop");
487 Scan
; -- past colon on extra label
489 -- Use the second label as the "real" label
491 Scan_State_Label
:= Scan_State
;
493 -- We will set Error_name as the Block_Label since
494 -- we really don't know which of the labels might
495 -- be used at the end of the loop or block!
497 Block_Label
:= Error_Name
;
499 -- If Id with no colon, then backup to point to the
500 -- Id and we will issue the message below when we try
501 -- to scan out the statement as some other form.
504 Restore_Scan_State
(Scan_State
); -- to second Id
509 -- Loop_Statement (labeled Loop_Statement)
511 if Token
= Tok_Loop
then
512 Append_To
(Statement_List
,
513 P_Loop_Statement
(Id_Node
));
515 -- While statement (labeled loop statement with WHILE)
517 elsif Token
= Tok_While
then
518 Append_To
(Statement_List
,
519 P_While_Statement
(Id_Node
));
521 -- Declare statement (labeled block statement with
524 elsif Token
= Tok_Declare
then
525 Append_To
(Statement_List
,
526 P_Declare_Statement
(Id_Node
));
528 -- Begin statement (labeled block statement with no
531 elsif Token
= Tok_Begin
then
532 Append_To
(Statement_List
,
533 P_Begin_Statement
(Id_Node
));
535 -- For statement (labeled loop statement with FOR)
537 elsif Token
= Tok_For
then
538 Append_To
(Statement_List
,
539 P_For_Statement
(Id_Node
));
541 -- Improper statement follows label. If we have an
542 -- expression token, then assume the colon was part
543 -- of a misplaced declaration.
545 elsif Token
not in Token_Class_Eterm
then
546 Restore_Scan_State
(Scan_State_Label
);
549 -- Otherwise complain we have inappropriate statement
553 ("loop or block statement must follow label");
556 Statement_Required
:= False;
558 -- Here we have an identifier followed by something
559 -- other than a colon, semicolon or assignment symbol.
560 -- The only valid possibility is a name extension symbol
562 elsif Token
in Token_Class_Namext
then
563 Restore_Scan_State
(Scan_State_Label
); -- to Id
566 -- Skip junk right parens in this context
568 Ignore
(Tok_Right_Paren
);
570 -- Check context following call
572 if Token
= Tok_Colon_Equal
then
573 Scan
; -- past colon equal
574 Append_To
(Statement_List
,
575 P_Assignment_Statement
(Name_Node
));
576 Statement_Required
:= False;
578 -- Check common case of = used instead of :=
580 elsif Token
= Tok_Equal
then
581 T_Colon_Equal
; -- give := expected message
582 Append_To
(Statement_List
,
583 P_Assignment_Statement
(Name_Node
));
584 Statement_Required
:= False;
586 -- Check apostrophe cases
588 elsif Token
= Tok_Apostrophe
then
589 Append_To
(Statement_List
,
590 P_Code_Statement
(Name_Node
));
591 Statement_Required
:= False;
593 -- The only other valid item after a name is ; which
594 -- means that the item we just scanned was a call.
596 elsif Token
= Tok_Semicolon
then
597 Append_To
(Statement_List
,
598 P_Statement_Name
(Name_Node
));
599 Scan
; -- past semicolon
600 Statement_Required
:= False;
602 -- A slash following an identifier or a selected
603 -- component in this situation is most likely a period
604 -- (see location of keys on keyboard).
606 elsif Token
= Tok_Slash
607 and then (Nkind
(Name_Node
) = N_Identifier
609 Nkind
(Name_Node
) = N_Selected_Component
)
611 Error_Msg_SC
-- CODEFIX
612 ("""/"" should be "".""");
613 Statement_Required
:= False;
616 -- Else we have a missing semicolon
620 Statement_Required
:= False;
623 -- If junk after identifier, check if identifier is an
624 -- instance of an incorrectly spelled keyword. If so, we
625 -- do nothing. The Bad_Spelling_Of will have reset Token
626 -- to the appropriate keyword, so the next time round the
627 -- loop we will process the modified token. Note that we
628 -- check for ELSIF before ELSE here. That's not accidental.
629 -- We don't want to identify a misspelling of ELSE as
630 -- ELSIF, and in particular we do not want to treat ELSEIF
634 Restore_Scan_State
(Scan_State_Label
); -- to identifier
636 if Bad_Spelling_Of
(Tok_Abort
)
637 or else Bad_Spelling_Of
(Tok_Accept
)
638 or else Bad_Spelling_Of
(Tok_Case
)
639 or else Bad_Spelling_Of
(Tok_Declare
)
640 or else Bad_Spelling_Of
(Tok_Delay
)
641 or else Bad_Spelling_Of
(Tok_Elsif
)
642 or else Bad_Spelling_Of
(Tok_Else
)
643 or else Bad_Spelling_Of
(Tok_End
)
644 or else Bad_Spelling_Of
(Tok_Exception
)
645 or else Bad_Spelling_Of
(Tok_Exit
)
646 or else Bad_Spelling_Of
(Tok_For
)
647 or else Bad_Spelling_Of
(Tok_Goto
)
648 or else Bad_Spelling_Of
(Tok_If
)
649 or else Bad_Spelling_Of
(Tok_Loop
)
650 or else Bad_Spelling_Of
(Tok_Or
)
651 or else Bad_Spelling_Of
(Tok_Pragma
)
652 or else Bad_Spelling_Of
(Tok_Raise
)
653 or else Bad_Spelling_Of
(Tok_Requeue
)
654 or else Bad_Spelling_Of
(Tok_Return
)
655 or else Bad_Spelling_Of
(Tok_Select
)
656 or else Bad_Spelling_Of
(Tok_When
)
657 or else Bad_Spelling_Of
(Tok_While
)
661 -- If not a bad spelling, then we really have junk
664 Scan
; -- past identifier again
666 -- If next token is first token on line, then we
667 -- consider that we were missing a semicolon after
668 -- the identifier, and process it as a procedure
669 -- call with no parameters.
671 if Token_Is_At_Start_Of_Line
then
672 Append_To
(Statement_List
,
673 P_Statement_Name
(Id_Node
));
674 T_Semicolon
; -- to give error message
675 Statement_Required
:= False;
677 -- Otherwise we give a missing := message and
678 -- simply abandon the junk that is there now.
681 T_Colon_Equal
; -- give := expected message
688 -- Statement starting with operator symbol. This could be
689 -- a call, a name starting an assignment, or a qualified
692 when Tok_Operator_Symbol
=>
696 -- An attempt at a range attribute or a qualified expression
697 -- must be illegal here (a code statement cannot possibly
698 -- allow qualification by a function name).
700 if Token
= Tok_Apostrophe
then
701 Error_Msg_SC
("apostrophe illegal here");
705 -- Scan possible assignment if we have a name
707 if Expr_Form
= EF_Name
708 and then Token
= Tok_Colon_Equal
710 Scan
; -- past colon equal
711 Append_To
(Statement_List
,
712 P_Assignment_Statement
(Name_Node
));
714 Append_To
(Statement_List
,
715 P_Statement_Name
(Name_Node
));
719 Statement_Required
:= False;
721 -- Label starting with << which must precede real statement
723 when Tok_Less_Less
=>
724 Append_To
(Statement_List
, P_Label
);
725 Statement_Required
:= True;
727 -- Pragma appearing as a statement in a statement sequence
731 Append_To
(Statement_List
, P_Pragma
);
737 Append_To
(Statement_List
, P_Abort_Statement
);
738 Statement_Required
:= False;
744 Append_To
(Statement_List
, P_Accept_Statement
);
745 Statement_Required
:= False;
747 -- Begin_Statement (Block_Statement with no declare, no label)
751 Append_To
(Statement_List
, P_Begin_Statement
);
752 Statement_Required
:= False;
758 Append_To
(Statement_List
, P_Case_Statement
);
759 Statement_Required
:= False;
761 -- Block_Statement with DECLARE and no label
765 Append_To
(Statement_List
, P_Declare_Statement
);
766 Statement_Required
:= False;
772 Append_To
(Statement_List
, P_Delay_Statement
);
773 Statement_Required
:= False;
779 Append_To
(Statement_List
, P_Exit_Statement
);
780 Statement_Required
:= False;
782 -- Loop_Statement with FOR and no label
786 Append_To
(Statement_List
, P_For_Statement
);
787 Statement_Required
:= False;
793 Append_To
(Statement_List
, P_Goto_Statement
);
794 Statement_Required
:= False;
800 Append_To
(Statement_List
, P_If_Statement
);
801 Statement_Required
:= False;
807 Append_To
(Statement_List
, P_Loop_Statement
);
808 Statement_Required
:= False;
814 Append_To
(Statement_List
, P_Null_Statement
);
815 Statement_Required
:= False;
821 Append_To
(Statement_List
, P_Raise_Statement
);
822 Statement_Required
:= False;
828 Append_To
(Statement_List
, P_Requeue_Statement
);
829 Statement_Required
:= False;
835 Append_To
(Statement_List
, P_Return_Statement
);
836 Statement_Required
:= False;
842 Append_To
(Statement_List
, P_Select_Statement
);
843 Statement_Required
:= False;
845 -- While_Statement (Block_Statement with while and no loop)
849 Append_To
(Statement_List
, P_While_Statement
);
850 Statement_Required
:= False;
852 -- Anything else is some kind of junk, signal an error message
853 -- and then raise Error_Resync, to merge with the normal
854 -- handling of a bad statement.
858 if Token
in Token_Class_Declk
then
862 Error_Msg_BC
-- CODEFIX
863 ("statement expected");
868 -- On error resynchronization, skip past next semicolon, and, since
869 -- we are still in the statement loop, look for next statement. We
870 -- set Statement_Required False to avoid an unnecessary error message
871 -- complaining that no statement was found (i.e. we consider the
872 -- junk to satisfy the requirement for a statement being present).
876 Resync_Past_Semicolon_Or_To_Loop_Or_Then
;
877 Statement_Required
:= False;
880 exit when SS_Flags
.Unco
;
884 return Statement_List
;
886 end P_Sequence_Of_Statements
;
892 -- Parsed by P_Sequence_Of_Statements (5.1), except for the case
893 -- of a statement of the form of a name, which is handled here. The
894 -- argument passed in is the tree for the name which has been scanned
895 -- The returned value is the corresponding statement form.
897 -- This routine is also used by Par.Prag for processing the procedure
898 -- call that appears as the second argument of a pragma Assert.
900 -- Error recovery: cannot raise Error_Resync
902 function P_Statement_Name
(Name_Node
: Node_Id
) return Node_Id
is
906 -- Case of Indexed component, which is a procedure call with arguments
908 if Nkind
(Name_Node
) = N_Indexed_Component
then
910 Prefix_Node
: constant Node_Id
:= Prefix
(Name_Node
);
911 Exprs_Node
: constant List_Id
:= Expressions
(Name_Node
);
914 Change_Node
(Name_Node
, N_Procedure_Call_Statement
);
915 Set_Name
(Name_Node
, Prefix_Node
);
916 Set_Parameter_Associations
(Name_Node
, Exprs_Node
);
920 -- Case of function call node, which is a really a procedure call
922 elsif Nkind
(Name_Node
) = N_Function_Call
then
924 Fname_Node
: constant Node_Id
:= Name
(Name_Node
);
925 Params_List
: constant List_Id
:=
926 Parameter_Associations
(Name_Node
);
929 Change_Node
(Name_Node
, N_Procedure_Call_Statement
);
930 Set_Name
(Name_Node
, Fname_Node
);
931 Set_Parameter_Associations
(Name_Node
, Params_List
);
935 -- Case of call to attribute that denotes a procedure. Here we
936 -- just leave the attribute reference unchanged.
938 elsif Nkind
(Name_Node
) = N_Attribute_Reference
939 and then Is_Procedure_Attribute_Name
(Attribute_Name
(Name_Node
))
943 -- All other cases of names are parameterless procedure calls
947 New_Node
(N_Procedure_Call_Statement
, Sloc
(Name_Node
));
948 Set_Name
(Stmt_Node
, Name_Node
);
952 end P_Statement_Name
;
954 ---------------------------
955 -- 5.1 Simple Statement --
956 ---------------------------
958 -- Parsed by P_Sequence_Of_Statements (5.1)
960 -----------------------------
961 -- 5.1 Compound Statement --
962 -----------------------------
964 -- Parsed by P_Sequence_Of_Statements (5.1)
966 -------------------------
967 -- 5.1 Null Statement --
968 -------------------------
970 -- NULL_STATEMENT ::= null;
972 -- The caller has already checked that the current token is null
974 -- Error recovery: cannot raise Error_Resync
976 function P_Null_Statement
return Node_Id
is
977 Null_Stmt_Node
: Node_Id
;
980 Null_Stmt_Node
:= New_Node
(N_Null_Statement
, Token_Ptr
);
983 return Null_Stmt_Node
;
984 end P_Null_Statement
;
990 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
992 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
994 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
995 -- (not an OPERATOR_SYMBOL)
997 -- The caller has already checked that the current token is <<
999 -- Error recovery: can raise Error_Resync
1001 function P_Label
return Node_Id
is
1002 Label_Node
: Node_Id
;
1005 Label_Node
:= New_Node
(N_Label
, Token_Ptr
);
1007 Set_Identifier
(Label_Node
, P_Identifier
(C_Greater_Greater
));
1009 Append_Elmt
(Label_Node
, Label_List
);
1013 -------------------------------
1014 -- 5.1 Statement Identifier --
1015 -------------------------------
1017 -- Statement label is parsed by P_Label (5.1)
1019 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1020 -- or P_While_Statement (5.5)
1022 -- Block label is parsed by P_Begin_Statement (5.6) or
1023 -- P_Declare_Statement (5.6)
1025 -------------------------------
1026 -- 5.2 Assignment Statement --
1027 -------------------------------
1029 -- ASSIGNMENT_STATEMENT ::=
1030 -- variable_NAME := EXPRESSION;
1032 -- Error recovery: can raise Error_Resync
1034 function P_Assignment_Statement
(LHS
: Node_Id
) return Node_Id
is
1035 Assign_Node
: Node_Id
;
1038 Assign_Node
:= New_Node
(N_Assignment_Statement
, Prev_Token_Ptr
);
1039 Set_Name
(Assign_Node
, LHS
);
1040 Set_Expression
(Assign_Node
, P_Expression_No_Right_Paren
);
1043 end P_Assignment_Statement
;
1045 -----------------------
1046 -- 5.3 If Statement --
1047 -----------------------
1050 -- if CONDITION then
1051 -- SEQUENCE_OF_STATEMENTS
1052 -- {elsif CONDITION then
1053 -- SEQUENCE_OF_STATEMENTS}
1055 -- SEQUENCE_OF_STATEMENTS]
1058 -- The caller has checked that the initial token is IF (or in the error
1059 -- case of a mysterious THEN, the initial token may simply be THEN, in
1060 -- which case, no condition (or IF) was scanned).
1062 -- Error recovery: can raise Error_Resync
1064 function P_If_Statement
return Node_Id
is
1066 Elsif_Node
: Node_Id
;
1069 procedure Add_Elsif_Part
;
1070 -- An internal procedure used to scan out a single ELSIF part. On entry
1071 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1072 -- scanned out and is in Prev_Token.
1074 procedure Check_If_Column
;
1075 -- An internal procedure used to check that THEN, ELSE, or ELSIF
1076 -- appear in the right place if column checking is enabled (i.e. if
1077 -- they are the first token on the line, then they must appear in
1078 -- the same column as the opening IF).
1080 procedure Check_Then_Column
;
1081 -- This procedure carries out the style checks for a THEN token
1082 -- Note that the caller has set Loc to the Source_Ptr value for
1083 -- the previous IF or ELSIF token. These checks apply only to a
1084 -- THEN at the start of a line.
1086 function Else_Should_Be_Elsif
return Boolean;
1087 -- An internal routine used to do a special error recovery check when
1088 -- an ELSE is encountered. It determines if the ELSE should be treated
1089 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1090 -- is followed by a sequence of tokens, starting on the same line as
1091 -- the ELSE, which are not expression terminators, followed by a THEN.
1092 -- On entry, the ELSE has been scanned out.
1094 procedure Add_Elsif_Part
is
1096 if No
(Elsif_Parts
(If_Node
)) then
1097 Set_Elsif_Parts
(If_Node
, New_List
);
1100 Elsif_Node
:= New_Node
(N_Elsif_Part
, Prev_Token_Ptr
);
1101 Loc
:= Prev_Token_Ptr
;
1102 Set_Condition
(Elsif_Node
, P_Condition
);
1106 (Elsif_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1107 Append
(Elsif_Node
, Elsif_Parts
(If_Node
));
1110 procedure Check_If_Column
is
1112 if RM_Column_Check
and then Token_Is_At_Start_Of_Line
1113 and then Start_Column
/= Scope
.Table
(Scope
.Last
).Ecol
1115 Error_Msg_Col
:= Scope
.Table
(Scope
.Last
).Ecol
;
1116 Error_Msg_SC
("(style) this token should be@");
1118 end Check_If_Column
;
1120 procedure Check_Then_Column
is
1122 if Token_Is_At_Start_Of_Line
and then Token
= Tok_Then
then
1126 Style
.Check_Then
(Loc
);
1129 end Check_Then_Column
;
1131 function Else_Should_Be_Elsif
return Boolean is
1132 Scan_State
: Saved_Scan_State
;
1135 if Token_Is_At_Start_Of_Line
then
1139 Save_Scan_State
(Scan_State
);
1142 if Token
in Token_Class_Eterm
then
1143 Restore_Scan_State
(Scan_State
);
1146 Scan
; -- past non-expression terminating token
1148 if Token
= Tok_Then
then
1149 Restore_Scan_State
(Scan_State
);
1155 end Else_Should_Be_Elsif
;
1157 -- Start of processing for P_If_Statement
1160 If_Node
:= New_Node
(N_If_Statement
, Token_Ptr
);
1163 Scope
.Table
(Scope
.Last
).Etyp
:= E_If
;
1164 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1165 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1166 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
1167 Scope
.Table
(Scope
.Last
).Node
:= If_Node
;
1169 if Token
= Tok_If
then
1172 Set_Condition
(If_Node
, P_Condition
);
1174 -- Deal with misuse of IF expression => used instead
1175 -- of WHEN expression =>
1177 if Token
= Tok_Arrow
then
1178 Error_Msg_SC
-- CODEFIX
1180 Scan
; -- past the arrow
1181 Pop_Scope_Stack
; -- remove unneeded entry
1188 Error_Msg_SC
("no IF for this THEN");
1189 Set_Condition
(If_Node
, Error
);
1195 (If_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1197 -- This loop scans out else and elsif parts
1200 if Token
= Tok_Elsif
then
1203 if Present
(Else_Statements
(If_Node
)) then
1204 Error_Msg_SP
("ELSIF cannot appear after ELSE");
1210 elsif Token
= Tok_Else
then
1214 if Else_Should_Be_Elsif
then
1215 Error_Msg_SP
-- CODEFIX
1216 ("ELSE should be ELSIF");
1220 -- Here we have an else that really is an else
1222 if Present
(Else_Statements
(If_Node
)) then
1223 Error_Msg_SP
("only one ELSE part allowed");
1225 (P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
),
1226 Else_Statements
(If_Node
));
1229 (If_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1233 -- If anything other than ELSE or ELSIF, exit the loop. The token
1234 -- had better be END (and in fact it had better be END IF), but
1235 -- we will let End_Statements take care of checking that.
1247 --------------------
1249 --------------------
1251 -- CONDITION ::= boolean_EXPRESSION
1253 function P_Condition
return Node_Id
is
1257 Cond
:= P_Expression_No_Right_Paren
;
1259 -- It is never possible for := to follow a condition, so if we get
1260 -- a := we assume it is a mistyped equality. Note that we do not try
1261 -- to reconstruct the tree correctly in this case, but we do at least
1262 -- give an accurate error message.
1264 if Token
= Tok_Colon_Equal
then
1265 while Token
= Tok_Colon_Equal
loop
1266 Error_Msg_SC
-- CODEFIX
1267 (""":="" should be ""=""");
1268 Scan
; -- past junk :=
1269 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
1274 -- Otherwise check for redundant parens
1278 and then Paren_Count
(Cond
) > 0
1280 Style
.Check_Xtra_Parens
(First_Sloc
(Cond
));
1283 -- And return the result
1289 -------------------------
1290 -- 5.4 Case Statement --
1291 -------------------------
1293 -- CASE_STATEMENT ::=
1294 -- case EXPRESSION is
1295 -- CASE_STATEMENT_ALTERNATIVE
1296 -- {CASE_STATEMENT_ALTERNATIVE}
1299 -- The caller has checked that the first token is CASE
1301 -- Can raise Error_Resync
1303 function P_Case_Statement
return Node_Id
is
1304 Case_Node
: Node_Id
;
1305 Alternatives_List
: List_Id
;
1306 First_When_Loc
: Source_Ptr
;
1309 Case_Node
:= New_Node
(N_Case_Statement
, Token_Ptr
);
1312 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
1313 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1314 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1315 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
1316 Scope
.Table
(Scope
.Last
).Node
:= Case_Node
;
1319 Set_Expression
(Case_Node
, P_Expression_No_Right_Paren
);
1322 -- Prepare to parse case statement alternatives
1324 Alternatives_List
:= New_List
;
1325 P_Pragmas_Opt
(Alternatives_List
);
1326 First_When_Loc
:= Token_Ptr
;
1328 -- Loop through case statement alternatives
1331 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1332 -- that it is a semantic check to ensure the proper use of OTHERS
1334 if Token
= Tok_When
or else Token
= Tok_Others
then
1335 Append
(P_Case_Statement_Alternative
, Alternatives_List
);
1337 -- If we have an END, then probably we are at the end of the case
1338 -- but we only exit if Check_End thinks the END was reasonable.
1340 elsif Token
= Tok_End
then
1341 exit when Check_End
;
1343 -- Here if token is other than WHEN, OTHERS or END. We definitely
1344 -- have an error, but the question is whether or not to get out of
1345 -- the case statement. We don't want to get out early, or we will
1346 -- get a slew of junk error messages for subsequent when tokens.
1348 -- If the token is not at the start of the line, or if it is indented
1349 -- with respect to the current case statement, then the best guess is
1350 -- that we are still supposed to be inside the case statement. We
1351 -- complain about the missing WHEN, and discard the junk statements.
1353 elsif not Token_Is_At_Start_Of_Line
1354 or else Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
1356 Error_Msg_BC
("WHEN (case statement alternative) expected");
1358 -- Here is a possibility for infinite looping if we don't make
1359 -- progress. So try to process statements, otherwise exit
1362 Error_Ptr
: constant Source_Ptr
:= Scan_Ptr
;
1364 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Whtm
));
1365 exit when Scan_Ptr
= Error_Ptr
and then Check_End
;
1368 -- Here we have a junk token at the start of the line and it is
1369 -- not indented. If Check_End thinks there is a missing END, then
1370 -- we will get out of the case, otherwise we keep going.
1373 exit when Check_End
;
1377 -- Make sure we have at least one alternative
1379 if No
(First_Non_Pragma
(Alternatives_List
)) then
1381 ("WHEN expected, must have at least one alternative in case",
1386 Set_Alternatives
(Case_Node
, Alternatives_List
);
1389 end P_Case_Statement
;
1391 -------------------------------------
1392 -- 5.4 Case Statement Alternative --
1393 -------------------------------------
1395 -- CASE_STATEMENT_ALTERNATIVE ::=
1396 -- when DISCRETE_CHOICE_LIST =>
1397 -- SEQUENCE_OF_STATEMENTS
1399 -- The caller has checked that the initial token is WHEN or OTHERS
1400 -- Error recovery: can raise Error_Resync
1402 function P_Case_Statement_Alternative
return Node_Id
is
1403 Case_Alt_Node
: Node_Id
;
1407 Style
.Check_Indentation
;
1410 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Token_Ptr
);
1411 T_When
; -- past WHEN (or give error in OTHERS case)
1412 Set_Discrete_Choices
(Case_Alt_Node
, P_Discrete_Choice_List
);
1414 Set_Statements
(Case_Alt_Node
, P_Sequence_Of_Statements
(SS_Sreq_Whtm
));
1415 return Case_Alt_Node
;
1416 end P_Case_Statement_Alternative
;
1418 -------------------------
1419 -- 5.5 Loop Statement --
1420 -------------------------
1422 -- LOOP_STATEMENT ::=
1423 -- [LOOP_STATEMENT_IDENTIFIER:]
1424 -- [ITERATION_SCHEME] loop
1425 -- SEQUENCE_OF_STATEMENTS
1426 -- end loop [loop_IDENTIFIER];
1428 -- ITERATION_SCHEME ::=
1430 -- | for LOOP_PARAMETER_SPECIFICATION
1432 -- The parsing of loop statements is handled by one of three functions
1433 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1434 -- on the initial keyword in the construct (excluding the identifier)
1438 -- This function parses the case where no iteration scheme is present
1440 -- The caller has checked that the initial token is LOOP. The parameter
1441 -- is the node identifiers for the loop label if any (or is set to Empty
1442 -- if there is no loop label).
1444 -- Error recovery : cannot raise Error_Resync
1446 function P_Loop_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1447 Loop_Node
: Node_Id
;
1448 Created_Name
: Node_Id
;
1452 Scope
.Table
(Scope
.Last
).Labl
:= Loop_Name
;
1453 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1454 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1455 Scope
.Table
(Scope
.Last
).Etyp
:= E_Loop
;
1457 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1460 if No
(Loop_Name
) then
1462 Make_Identifier
(Sloc
(Loop_Node
),
1463 Chars
=> Set_Loop_Block_Name
('L'));
1464 Set_Comes_From_Source
(Created_Name
, False);
1465 Set_Has_Created_Identifier
(Loop_Node
, True);
1466 Set_Identifier
(Loop_Node
, Created_Name
);
1467 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1469 Set_Identifier
(Loop_Node
, Loop_Name
);
1472 Append_Elmt
(Loop_Node
, Label_List
);
1473 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1474 End_Statements
(Loop_Node
);
1476 end P_Loop_Statement
;
1480 -- This function parses a loop statement with a FOR iteration scheme
1482 -- The caller has checked that the initial token is FOR. The parameter
1483 -- is the node identifier for the block label if any (or is set to Empty
1484 -- if there is no block label).
1486 -- Note: the caller fills in the Identifier field if a label was present
1488 -- Error recovery: can raise Error_Resync
1490 function P_For_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1491 Loop_Node
: Node_Id
;
1492 Iter_Scheme_Node
: Node_Id
;
1493 Loop_For_Flag
: Boolean;
1494 Created_Name
: Node_Id
;
1498 Scope
.Table
(Scope
.Last
).Labl
:= Loop_Name
;
1499 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1500 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1501 Scope
.Table
(Scope
.Last
).Etyp
:= E_Loop
;
1503 Loop_For_Flag
:= (Prev_Token
= Tok_Loop
);
1505 Iter_Scheme_Node
:= New_Node
(N_Iteration_Scheme
, Token_Ptr
);
1506 Set_Loop_Parameter_Specification
1507 (Iter_Scheme_Node
, P_Loop_Parameter_Specification
);
1509 -- The following is a special test so that a miswritten for loop such
1510 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1511 -- entry in the scope stack. We don't bother to actually fix up the
1512 -- tree in this case since it's not worth the effort. Instead we just
1513 -- eat up the loop junk, leaving the entry for what now looks like an
1514 -- unmodified loop intact.
1516 if Loop_For_Flag
and then Token
= Tok_Semicolon
then
1517 Error_Msg_SC
("LOOP belongs here, not before FOR");
1524 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1526 if No
(Loop_Name
) then
1528 Make_Identifier
(Sloc
(Loop_Node
),
1529 Chars
=> Set_Loop_Block_Name
('L'));
1530 Set_Comes_From_Source
(Created_Name
, False);
1531 Set_Has_Created_Identifier
(Loop_Node
, True);
1532 Set_Identifier
(Loop_Node
, Created_Name
);
1533 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1535 Set_Identifier
(Loop_Node
, Loop_Name
);
1539 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1540 End_Statements
(Loop_Node
);
1541 Set_Iteration_Scheme
(Loop_Node
, Iter_Scheme_Node
);
1542 Append_Elmt
(Loop_Node
, Label_List
);
1545 end P_For_Statement
;
1547 -- P_While_Statement
1549 -- This procedure scans a loop statement with a WHILE iteration scheme
1551 -- The caller has checked that the initial token is WHILE. The parameter
1552 -- is the node identifier for the block label if any (or is set to Empty
1553 -- if there is no block label).
1555 -- Error recovery: cannot raise Error_Resync
1557 function P_While_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1558 Loop_Node
: Node_Id
;
1559 Iter_Scheme_Node
: Node_Id
;
1560 Loop_While_Flag
: Boolean;
1561 Created_Name
: Node_Id
;
1565 Scope
.Table
(Scope
.Last
).Labl
:= Loop_Name
;
1566 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1567 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1568 Scope
.Table
(Scope
.Last
).Etyp
:= E_Loop
;
1570 Loop_While_Flag
:= (Prev_Token
= Tok_Loop
);
1571 Iter_Scheme_Node
:= New_Node
(N_Iteration_Scheme
, Token_Ptr
);
1573 Set_Condition
(Iter_Scheme_Node
, P_Condition
);
1575 -- The following is a special test so that a miswritten for loop such
1576 -- as "loop while I > 10;" is handled nicely, without making an extra
1577 -- entry in the scope stack. We don't bother to actually fix up the
1578 -- tree in this case since it's not worth the effort. Instead we just
1579 -- eat up the loop junk, leaving the entry for what now looks like an
1580 -- unmodified loop intact.
1582 if Loop_While_Flag
and then Token
= Tok_Semicolon
then
1583 Error_Msg_SC
("LOOP belongs here, not before WHILE");
1590 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1593 if No
(Loop_Name
) then
1595 Make_Identifier
(Sloc
(Loop_Node
),
1596 Chars
=> Set_Loop_Block_Name
('L'));
1597 Set_Comes_From_Source
(Created_Name
, False);
1598 Set_Has_Created_Identifier
(Loop_Node
, True);
1599 Set_Identifier
(Loop_Node
, Created_Name
);
1600 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1602 Set_Identifier
(Loop_Node
, Loop_Name
);
1605 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1606 End_Statements
(Loop_Node
);
1607 Set_Iteration_Scheme
(Loop_Node
, Iter_Scheme_Node
);
1608 Append_Elmt
(Loop_Node
, Label_List
);
1611 end P_While_Statement
;
1613 ---------------------------------------
1614 -- 5.5 Loop Parameter Specification --
1615 ---------------------------------------
1617 -- LOOP_PARAMETER_SPECIFICATION ::=
1618 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1620 -- Error recovery: cannot raise Error_Resync
1622 function P_Loop_Parameter_Specification
return Node_Id
is
1623 Loop_Param_Specification_Node
: Node_Id
;
1626 Scan_State
: Saved_Scan_State
;
1629 Loop_Param_Specification_Node
:=
1630 New_Node
(N_Loop_Parameter_Specification
, Token_Ptr
);
1632 Save_Scan_State
(Scan_State
);
1633 ID_Node
:= P_Defining_Identifier
(C_In
);
1634 Set_Defining_Identifier
(Loop_Param_Specification_Node
, ID_Node
);
1636 if Token
= Tok_Left_Paren
then
1637 Error_Msg_SC
("subscripted loop parameter not allowed");
1638 Restore_Scan_State
(Scan_State
);
1639 Discard_Junk_Node
(P_Name
);
1641 elsif Token
= Tok_Dot
then
1642 Error_Msg_SC
("selected loop parameter not allowed");
1643 Restore_Scan_State
(Scan_State
);
1644 Discard_Junk_Node
(P_Name
);
1649 if Token
= Tok_Reverse
then
1650 Scan
; -- past REVERSE
1651 Set_Reverse_Present
(Loop_Param_Specification_Node
, True);
1654 Set_Discrete_Subtype_Definition
1655 (Loop_Param_Specification_Node
, P_Discrete_Subtype_Definition
);
1656 return Loop_Param_Specification_Node
;
1659 when Error_Resync
=>
1661 end P_Loop_Parameter_Specification
;
1663 --------------------------
1664 -- 5.6 Block Statement --
1665 --------------------------
1667 -- BLOCK_STATEMENT ::=
1668 -- [block_STATEMENT_IDENTIFIER:]
1670 -- DECLARATIVE_PART]
1672 -- HANDLED_SEQUENCE_OF_STATEMENTS
1673 -- end [block_IDENTIFIER];
1675 -- The parsing of block statements is handled by one of the two functions
1676 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1677 -- a declare section is present
1679 -- P_Declare_Statement
1681 -- This function parses a block statement with DECLARE present
1683 -- The caller has checked that the initial token is DECLARE
1685 -- Error recovery: cannot raise Error_Resync
1687 function P_Declare_Statement
1688 (Block_Name
: Node_Id
:= Empty
)
1691 Block_Node
: Node_Id
;
1692 Created_Name
: Node_Id
;
1695 Block_Node
:= New_Node
(N_Block_Statement
, Token_Ptr
);
1698 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
1699 Scope
.Table
(Scope
.Last
).Lreq
:= Present
(Block_Name
);
1700 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1701 Scope
.Table
(Scope
.Last
).Labl
:= Block_Name
;
1702 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1704 Scan
; -- past DECLARE
1706 if No
(Block_Name
) then
1708 Make_Identifier
(Sloc
(Block_Node
),
1709 Chars
=> Set_Loop_Block_Name
('B'));
1710 Set_Comes_From_Source
(Created_Name
, False);
1711 Set_Has_Created_Identifier
(Block_Node
, True);
1712 Set_Identifier
(Block_Node
, Created_Name
);
1713 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1715 Set_Identifier
(Block_Node
, Block_Name
);
1718 Append_Elmt
(Block_Node
, Label_List
);
1719 Parse_Decls_Begin_End
(Block_Node
);
1721 end P_Declare_Statement
;
1723 -- P_Begin_Statement
1725 -- This function parses a block statement with no DECLARE present
1727 -- The caller has checked that the initial token is BEGIN
1729 -- Error recovery: cannot raise Error_Resync
1731 function P_Begin_Statement
1732 (Block_Name
: Node_Id
:= Empty
)
1735 Block_Node
: Node_Id
;
1736 Created_Name
: Node_Id
;
1739 Block_Node
:= New_Node
(N_Block_Statement
, Token_Ptr
);
1742 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
1743 Scope
.Table
(Scope
.Last
).Lreq
:= Present
(Block_Name
);
1744 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1745 Scope
.Table
(Scope
.Last
).Labl
:= Block_Name
;
1746 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1748 if No
(Block_Name
) then
1750 Make_Identifier
(Sloc
(Block_Node
),
1751 Chars
=> Set_Loop_Block_Name
('B'));
1752 Set_Comes_From_Source
(Created_Name
, False);
1753 Set_Has_Created_Identifier
(Block_Node
, True);
1754 Set_Identifier
(Block_Node
, Created_Name
);
1755 Scope
.Table
(Scope
.Last
).Labl
:= Created_Name
;
1757 Set_Identifier
(Block_Node
, Block_Name
);
1760 Append_Elmt
(Block_Node
, Label_List
);
1762 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
1763 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
1765 Set_Handled_Statement_Sequence
1766 (Block_Node
, P_Handled_Sequence_Of_Statements
);
1767 End_Statements
(Handled_Statement_Sequence
(Block_Node
));
1769 end P_Begin_Statement
;
1771 -------------------------
1772 -- 5.7 Exit Statement --
1773 -------------------------
1775 -- EXIT_STATEMENT ::=
1776 -- exit [loop_NAME] [when CONDITION];
1778 -- The caller has checked that the initial token is EXIT
1780 -- Error recovery: can raise Error_Resync
1782 function P_Exit_Statement
return Node_Id
is
1783 Exit_Node
: Node_Id
;
1785 function Missing_Semicolon_On_Exit
return Boolean;
1786 -- This function deals with the following specialized situation
1789 -- exit [identifier]
1792 -- This looks like a messed up EXIT WHEN, when in fact the problem
1793 -- is a missing semicolon. It is called with Token pointing to the
1794 -- WHEN token, and returns True if a semicolon is missing before
1795 -- the WHEN as in the above example.
1797 -------------------------------
1798 -- Missing_Semicolon_On_Exit --
1799 -------------------------------
1801 function Missing_Semicolon_On_Exit
return Boolean is
1802 State
: Saved_Scan_State
;
1805 if not Token_Is_At_Start_Of_Line
then
1808 elsif Scope
.Table
(Scope
.Last
).Etyp
/= E_Case
then
1812 Save_Scan_State
(State
);
1814 Scan
; -- past token after WHEN
1816 if Token
= Tok_Arrow
then
1817 Restore_Scan_State
(State
);
1820 Restore_Scan_State
(State
);
1824 end Missing_Semicolon_On_Exit
;
1826 -- Start of processing for P_Exit_Statement
1829 Exit_Node
:= New_Node
(N_Exit_Statement
, Token_Ptr
);
1832 if Token
= Tok_Identifier
then
1833 Set_Name
(Exit_Node
, P_Qualified_Simple_Name
);
1835 elsif Style_Check
then
1836 -- This EXIT has no name, so check that
1837 -- the innermost loop is unnamed too.
1839 Check_No_Exit_Name
:
1840 for J
in reverse 1 .. Scope
.Last
loop
1841 if Scope
.Table
(J
).Etyp
= E_Loop
then
1842 if Present
(Scope
.Table
(J
).Labl
)
1843 and then Comes_From_Source
(Scope
.Table
(J
).Labl
)
1845 -- Innermost loop in fact had a name, style check fails
1847 Style
.No_Exit_Name
(Scope
.Table
(J
).Labl
);
1850 exit Check_No_Exit_Name
;
1852 end loop Check_No_Exit_Name
;
1855 if Token
= Tok_When
and then not Missing_Semicolon_On_Exit
then
1857 Set_Condition
(Exit_Node
, P_Condition
);
1859 -- Allow IF instead of WHEN, giving error message
1861 elsif Token
= Tok_If
then
1863 Scan
; -- past IF used in place of WHEN
1864 Set_Condition
(Exit_Node
, P_Expression_No_Right_Paren
);
1869 end P_Exit_Statement
;
1871 -------------------------
1872 -- 5.8 Goto Statement --
1873 -------------------------
1875 -- GOTO_STATEMENT ::= goto label_NAME;
1877 -- The caller has checked that the initial token is GOTO (or TO in the
1878 -- error case where GO and TO were incorrectly separated).
1880 -- Error recovery: can raise Error_Resync
1882 function P_Goto_Statement
return Node_Id
is
1883 Goto_Node
: Node_Id
;
1886 Goto_Node
:= New_Node
(N_Goto_Statement
, Token_Ptr
);
1887 Scan
; -- past GOTO (or TO)
1888 Set_Name
(Goto_Node
, P_Qualified_Simple_Name_Resync
);
1889 Append_Elmt
(Goto_Node
, Goto_List
);
1893 end P_Goto_Statement
;
1895 ---------------------------
1896 -- Parse_Decls_Begin_End --
1897 ---------------------------
1899 -- This function parses the construct:
1903 -- HANDLED_SEQUENCE_OF_STATEMENTS
1906 -- The caller has built the scope stack entry, and created the node to
1907 -- whose Declarations and Handled_Statement_Sequence fields are to be
1908 -- set. On return these fields are filled in (except in the case of a
1909 -- task body, where the handled statement sequence is optional, and may
1910 -- thus be Empty), and the scan is positioned past the End sequence.
1912 -- If the BEGIN is missing, then the parent node is used to help construct
1913 -- an appropriate missing BEGIN message. Possibilities for the parent are:
1915 -- N_Block_Statement declare block
1916 -- N_Entry_Body entry body
1917 -- N_Package_Body package body (begin part optional)
1918 -- N_Subprogram_Body procedure or function body
1919 -- N_Task_Body task body
1921 -- Note: in the case of a block statement, there is definitely a DECLARE
1922 -- present (because a Begin statement without a DECLARE is handled by the
1923 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
1925 -- Error recovery: cannot raise Error_Resync
1927 procedure Parse_Decls_Begin_End
(Parent
: Node_Id
) is
1928 Body_Decl
: Node_Id
;
1929 Body_Sloc
: Source_Ptr
;
1932 Parent_Nkind
: Node_Kind
;
1933 Spec_Node
: Node_Id
;
1936 procedure Missing_Begin
(Msg
: String);
1937 -- Called to post a missing begin message. In the normal case this is
1938 -- posted at the start of the current token. A special case arises when
1939 -- P_Declarative_Items has previously found a missing begin, in which
1940 -- case we replace the original error message.
1942 procedure Set_Null_HSS
(Parent
: Node_Id
);
1943 -- Construct an empty handled statement sequence and install in Parent
1944 -- Leaves HSS set to reference the newly constructed statement sequence.
1950 procedure Missing_Begin
(Msg
: String) is
1952 if Missing_Begin_Msg
= No_Error_Msg
then
1955 Change_Error_Text
(Missing_Begin_Msg
, Msg
);
1957 -- Purge any messages issued after than, since a missing begin
1958 -- can cause a lot of havoc, and it is better not to dump these
1959 -- cascaded messages on the user.
1961 Purge_Messages
(Get_Location
(Missing_Begin_Msg
), Prev_Token_Ptr
);
1969 procedure Set_Null_HSS
(Parent
: Node_Id
) is
1974 Make_Null_Statement
(Token_Ptr
);
1975 Set_Comes_From_Source
(Null_Stm
, False);
1978 Make_Handled_Sequence_Of_Statements
(Token_Ptr
,
1979 Statements
=> New_List
(Null_Stm
));
1980 Set_Comes_From_Source
(HSS
, False);
1982 Set_Handled_Statement_Sequence
(Parent
, HSS
);
1985 -- Start of processing for Parse_Decls_Begin_End
1988 Decls
:= P_Declarative_Part
;
1990 -- Check for misplacement of later vs basic declarations in Ada 83
1992 if Ada_Version
= Ada_83
then
1993 Decl
:= First
(Decls
);
1995 -- Loop through sequence of basic declarative items
1997 Outer
: while Present
(Decl
) loop
1998 if Nkind
(Decl
) /= N_Subprogram_Body
1999 and then Nkind
(Decl
) /= N_Package_Body
2000 and then Nkind
(Decl
) /= N_Task_Body
2001 and then Nkind
(Decl
) not in N_Body_Stub
2005 -- Once a body is encountered, we only allow later declarative
2006 -- items. The inner loop checks the rest of the list.
2009 Body_Sloc
:= Sloc
(Decl
);
2011 Inner
: while Present
(Decl
) loop
2012 if Nkind
(Decl
) not in N_Later_Decl_Item
2013 and then Nkind
(Decl
) /= N_Pragma
2015 if Ada_Version
= Ada_83
then
2016 Error_Msg_Sloc
:= Body_Sloc
;
2018 ("(Ada 83) decl cannot appear after body#", Decl
);
2028 -- Here is where we deal with the case of IS used instead of semicolon.
2029 -- Specifically, if the last declaration in the declarative part is a
2030 -- subprogram body still marked as having a bad IS, then this is where
2031 -- we decide that the IS should really have been a semicolon and that
2032 -- the body should have been a declaration. Note that if the bad IS
2033 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2034 -- then the Bad_Is_Detected flag would have been reset by now.
2036 Body_Decl
:= Last
(Decls
);
2038 if Present
(Body_Decl
)
2039 and then Nkind
(Body_Decl
) = N_Subprogram_Body
2040 and then Bad_Is_Detected
(Body_Decl
)
2042 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2043 -- What we have now is a subprogram body with attached declarations
2044 -- and a possible statement sequence.
2046 -- First step is to take the declarations that were part of the bogus
2047 -- subprogram body and append them to the outer declaration chain.
2048 -- In other words we append them past the body (which we will later
2049 -- convert into a declaration).
2051 Append_List
(Declarations
(Body_Decl
), Decls
);
2053 -- Now take the handled statement sequence of the bogus body and
2054 -- set it as the statement sequence for the outer construct. Note
2055 -- that it may be empty (we specially allowed a missing BEGIN for
2056 -- a subprogram body marked as having a bad IS -- see below).
2058 Set_Handled_Statement_Sequence
(Parent
,
2059 Handled_Statement_Sequence
(Body_Decl
));
2061 -- Next step is to convert the old body node to a declaration node
2063 Spec_Node
:= Specification
(Body_Decl
);
2064 Change_Node
(Body_Decl
, N_Subprogram_Declaration
);
2065 Set_Specification
(Body_Decl
, Spec_Node
);
2067 -- Final step is to put the declarations for the parent where
2068 -- they belong, and then fall through the IF to scan out the
2071 Set_Declarations
(Parent
, Decls
);
2073 -- This is the normal case (i.e. any case except the bad IS case)
2074 -- If we have a BEGIN, then scan out the sequence of statements, and
2075 -- also reset the expected column for the END to match the BEGIN.
2078 Set_Declarations
(Parent
, Decls
);
2080 if Token
= Tok_Begin
then
2082 Style
.Check_Indentation
;
2085 Error_Msg_Col
:= Scope
.Table
(Scope
.Last
).Ecol
;
2088 and then Token_Is_At_Start_Of_Line
2089 and then Start_Column
/= Error_Msg_Col
2091 Error_Msg_SC
("(style) BEGIN in wrong column, should be@");
2094 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
2097 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
2099 Set_Handled_Statement_Sequence
(Parent
,
2100 P_Handled_Sequence_Of_Statements
);
2105 Parent_Nkind
:= Nkind
(Parent
);
2107 -- A special check for the missing IS case. If we have a
2108 -- subprogram body that was marked as having a suspicious
2109 -- IS, and the current token is END, then we simply confirm
2110 -- the suspicion, and do not require a BEGIN to be present
2112 if Parent_Nkind
= N_Subprogram_Body
2113 and then Token
= Tok_End
2114 and then Scope
.Table
(Scope
.Last
).Etyp
= E_Suspicious_Is
2116 Scope
.Table
(Scope
.Last
).Etyp
:= E_Bad_Is
;
2118 -- Otherwise BEGIN is not required for a package body, so we
2119 -- don't mind if it is missing, but we do construct a dummy
2120 -- one (so that we have somewhere to set End_Label).
2122 -- However if we have something other than a BEGIN which
2123 -- looks like it might be statements, then we signal a missing
2124 -- BEGIN for these cases as well. We define "something which
2125 -- looks like it might be statements" as a token other than
2126 -- END, EOF, or a token which starts declarations.
2128 elsif Parent_Nkind
= N_Package_Body
2129 and then (Token
= Tok_End
2130 or else Token
= Tok_EOF
2131 or else Token
in Token_Class_Declk
)
2133 Set_Null_HSS
(Parent
);
2135 -- These are cases in which a BEGIN is required and not present
2138 Set_Null_HSS
(Parent
);
2140 -- Prepare to issue error message
2142 Error_Msg_Sloc
:= Scope
.Table
(Scope
.Last
).Sloc
;
2143 Error_Msg_Node_1
:= Scope
.Table
(Scope
.Last
).Labl
;
2145 -- Now issue appropriate message
2147 if Parent_Nkind
= N_Block_Statement
then
2148 Missing_Begin
("missing BEGIN for DECLARE#!");
2150 elsif Parent_Nkind
= N_Entry_Body
then
2151 Missing_Begin
("missing BEGIN for ENTRY#!");
2153 elsif Parent_Nkind
= N_Subprogram_Body
then
2154 if Nkind
(Specification
(Parent
))
2155 = N_Function_Specification
2157 Missing_Begin
("missing BEGIN for function&#!");
2159 Missing_Begin
("missing BEGIN for procedure&#!");
2162 -- The case for package body arises only when
2163 -- we have possible statement junk present.
2165 elsif Parent_Nkind
= N_Package_Body
then
2166 Missing_Begin
("missing BEGIN for package body&#!");
2169 pragma Assert
(Parent_Nkind
= N_Task_Body
);
2170 Missing_Begin
("missing BEGIN for task body&#!");
2173 -- Here we pick up the statements after the BEGIN that
2174 -- should have been present but was not. We don't insist
2175 -- on statements being present if P_Declarative_Part had
2176 -- already found a missing BEGIN, since it might have
2177 -- swallowed a lone statement into the declarative part.
2179 if Missing_Begin_Msg
/= No_Error_Msg
2180 and then Token
= Tok_End
2184 Set_Handled_Statement_Sequence
(Parent
,
2185 P_Handled_Sequence_Of_Statements
);
2191 -- Here with declarations and handled statement sequence scanned
2193 if Present
(Handled_Statement_Sequence
(Parent
)) then
2194 End_Statements
(Handled_Statement_Sequence
(Parent
));
2199 -- We know that End_Statements removed an entry from the scope stack
2200 -- (because it is required to do so under all circumstances). We can
2201 -- therefore reference the entry it removed one past the stack top.
2202 -- What we are interested in is whether it was a case of a bad IS.
2204 if Scope
.Table
(Scope
.Last
+ 1).Etyp
= E_Bad_Is
then
2205 Error_Msg
-- CODEFIX
2206 ("|IS should be "";""", Scope
.Table
(Scope
.Last
+ 1).S_Is
);
2207 Set_Bad_Is_Detected
(Parent
, True);
2210 end Parse_Decls_Begin_End
;
2212 -------------------------
2213 -- Set_Loop_Block_Name --
2214 -------------------------
2216 function Set_Loop_Block_Name
(L
: Character) return Name_Id
is
2218 Name_Buffer
(1) := L
;
2219 Name_Buffer
(2) := '_';
2221 Loop_Block_Count
:= Loop_Block_Count
+ 1;
2222 Add_Nat_To_Name_Buffer
(Loop_Block_Count
);
2224 end Set_Loop_Block_Name
;
2230 procedure Then_Scan
is
2234 while Token
= Tok_Then
loop
2235 Error_Msg_SC
-- CODEFIX
2240 if Token
= Tok_And
or else Token
= Tok_Or
then
2241 Error_Msg_SC
("unexpected logical operator");
2242 Scan
; -- past logical operator
2244 if (Prev_Token
= Tok_And
and then Token
= Tok_Then
)
2246 (Prev_Token
= Tok_Or
and then Token
= Tok_Else
)
2251 Discard_Junk_Node
(P_Expression
);
2254 if Token
= Tok_Then
then