1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks
(All_Checks
);
27 -- Turn off subprogram body ordering check. Subprograms are in order by RM
28 -- section rather than alphabetical.
30 with Sinfo
.CN
; use Sinfo
.CN
;
35 -- Local functions, used only in this chapter
37 function P_Case_Statement
return Node_Id
;
38 function P_Case_Statement_Alternative
return Node_Id
;
39 function P_Exit_Statement
return Node_Id
;
40 function P_Goto_Statement
return Node_Id
;
41 function P_If_Statement
return Node_Id
;
42 function P_Label
return Node_Id
;
43 function P_Null_Statement
return Node_Id
;
45 function P_Assignment_Statement
(LHS
: Node_Id
) return Node_Id
;
46 -- Parse assignment statement. On entry, the caller has scanned the left
47 -- hand side (passed in as Lhs), and the colon-equal (or some symbol
48 -- taken to be an error equivalent such as equal).
50 function P_Begin_Statement
(Block_Name
: Node_Id
:= Empty
) return Node_Id
;
51 -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is
52 -- the N_Identifier node for the label on the block. If Block_Name is
53 -- Empty on entry (the default), then the block statement is unlabeled.
55 function P_Declare_Statement
(Block_Name
: Node_Id
:= Empty
) return Node_Id
;
56 -- Parse declare block. If Block_Name is non-Empty on entry, it is
57 -- the N_Identifier node for the label on the block. If Block_Name is
58 -- Empty on entry (the default), then the block statement is unlabeled.
60 function P_For_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
;
61 -- Parse for statement. If Loop_Name is non-Empty on entry, it is
62 -- the N_Identifier node for the label on the loop. If Loop_Name is
63 -- Empty on entry (the default), then the for statement is unlabeled.
65 function P_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} {LABEL}
88 -- Note: the final label is an Ada 2012 addition.
91 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
93 -- SIMPLE_STATEMENT ::= NULL_STATEMENT
94 -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT
95 -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT
96 -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT
97 -- | REQUEUE_STATEMENT | DELAY_STATEMENT
98 -- | ABORT_STATEMENT | RAISE_STATEMENT
101 -- COMPOUND_STATEMENT ::=
102 -- IF_STATEMENT | CASE_STATEMENT
103 -- | LOOP_STATEMENT | BLOCK_STATEMENT
104 -- | ACCEPT_STATEMENT | SELECT_STATEMENT
106 -- This procedure scans a sequence of statements. SS_Flags indicates
107 -- termination conditions for the sequence. In addition, the sequence is
108 -- always terminated by encountering END or end of file. If one of the six
109 -- above terminators is encountered with the corresponding SS_Flags flag
110 -- not set, then the action taken is as follows:
112 -- If the keyword occurs to the left of the expected column of the end
113 -- for the current sequence (as recorded in the current end context),
114 -- then it is assumed to belong to an outer context, and is considered
115 -- to terminate the sequence of statements.
117 -- If the keyword occurs to the right of, or in the expected column of
118 -- the end for the current sequence, then an error message is output,
119 -- the keyword together with its associated context is skipped, and
120 -- the statement scan continues until another terminator is found.
122 -- Note that the first action means that control can return to the caller
123 -- with Token set to a terminator other than one of those specified by the
124 -- SS_Flags parameter. The caller should treat such a case as equivalent to
127 -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at
128 -- least one real statement (other than a pragma) is required in the
129 -- statement sequence. During the processing of the sequence, this
130 -- flag is manipulated to indicate the current status of the requirement
131 -- for a statement. For example, it is turned off by the occurrence of a
132 -- statement, and back on by a label (which requires a following statement)
134 -- Error recovery: cannot raise Error_Resync. If an error occurs during
135 -- parsing a statement, then the scan pointer is advanced past the next
136 -- semicolon and the parse continues.
138 function P_Sequence_Of_Statements
139 (SS_Flags
: SS_Rec
; Handled
: Boolean := False) return List_Id
141 Statement_Required
: Boolean := SS_Flags
.Sreq
;
142 -- This flag indicates if a subsequent statement (other than a pragma)
143 -- is required. It is initialized from the Sreq flag, and modified as
144 -- statements are scanned (a statement turns it off, and a label turns
145 -- it back on again since a statement must follow a label).
146 -- Note : this final requirement is lifted in Ada 2012.
148 Statement_Seen
: Boolean := False;
149 -- In Ada 2012, a label can end a sequence of statements, but the
150 -- sequence cannot contain only labels. This flag is set whenever a
151 -- label is encountered, to enforce this rule at the end of a sequence.
153 Scan_State_Label
: Saved_Scan_State
;
154 Scan_State
: Saved_Scan_State
;
156 Statement_List
: constant List_Id
:= New_List
;
157 Block_Label
: Name_Id
;
161 Decl_Loc
, Label_Loc
: Source_Ptr
:= No_Location
;
162 -- Sloc of the first declaration/label encountered, if any.
164 procedure Test_Statement_Required
;
165 -- Flag error if Statement_Required flag set
167 -----------------------------
168 -- Test_Statement_Required --
169 -----------------------------
171 procedure Test_Statement_Required
is
172 function All_Pragmas
return Boolean;
173 -- Return True if statement list is all pragmas
179 function All_Pragmas
return Boolean is
182 S
:= First
(Statement_List
);
183 while Present
(S
) loop
184 if Nkind
(S
) /= N_Pragma
then
194 -- Start of processing for Test_Statement_Required
197 if Statement_Required
then
199 -- Check no statement required after label in Ada 2012, and that
200 -- it is OK to have nothing but pragmas in a statement sequence.
202 if Ada_Version
>= Ada_2012
203 and then not Is_Empty_List
(Statement_List
)
205 ((Nkind
(Last
(Statement_List
)) = N_Label
206 and then Statement_Seen
)
211 -- If not Ada 2012, or not special case above, and no declaration
212 -- seen (as allowed in Ada 2020), give error message.
214 elsif No
(Decl_Loc
) then
215 Error_Msg_BC
-- CODEFIX
216 ("statement expected");
219 end Test_Statement_Required
;
221 -- Start of processing for P_Sequence_Of_Statements
224 -- In Ada 2022, we allow declarative items to be mixed with
225 -- statements. The loop below alternates between calling
226 -- P_Declarative_Items to parse zero or more declarative items,
227 -- and parsing a statement.
230 Ignore
(Tok_Semicolon
);
233 Num_Statements
: constant Nat
:= List_Length
(Statement_List
);
236 (Statement_List
, Declare_Expression
=> False,
237 In_Spec
=> False, In_Statements
=> True);
239 -- Use the length of the list to determine whether we parsed
240 -- any declarative items. If so, it's an error unless language
241 -- extensions are enabled.
243 if List_Length
(Statement_List
) > Num_Statements
then
244 if All_Errors_Mode
or else No
(Decl_Loc
) then
245 Decl_Loc
:= Sloc
(Pick
(Statement_List
, Num_Statements
+ 1));
247 Error_Msg_GNAT_Extension
248 ("declarations mixed with statements",
249 Sloc
(Pick
(Statement_List
, Num_Statements
+ 1)));
254 begin -- handle Error_Resync
256 Style
.Check_Indentation
;
259 -- Deal with reserved identifier (in assignment or call)
261 if Is_Reserved_Identifier
then
262 Save_Scan_State
(Scan_State
); -- at possible bad identifier
263 Scan
; -- and scan past it
265 -- We have an reserved word which is spelled in identifier
266 -- style, so the question is whether it really is intended
267 -- to be an identifier.
270 -- If followed by a semicolon, then it is an identifier,
271 -- with the exception of the cases tested for below.
273 (Token
= Tok_Semicolon
274 and then Prev_Token
not in
275 Tok_Return | Tok_Null | Tok_Raise | Tok_End | Tok_Exit
)
277 -- If followed by colon, colon-equal, or dot, then we
278 -- definitely have an identifier (could not be reserved)
280 or else Token
in Tok_Colon | Tok_Colon_Equal | Tok_Dot
282 -- Left paren means we have an identifier except for those
283 -- reserved words that can legitimately be followed by a
287 (Token
= Tok_Left_Paren
288 and then Prev_Token
not in
289 Tok_Case | Tok_Delay | Tok_If | Tok_Elsif | Tok_Return |
290 Tok_When | Tok_While | Tok_Separate
)
292 -- Here we have an apparent reserved identifier and the
293 -- token past it is appropriate to this usage (and would
294 -- be a definite error if this is not an identifier). What
295 -- we do is to use P_Identifier to fix up the identifier,
296 -- and then fall into the normal processing.
298 Restore_Scan_State
(Scan_State
); -- back to the ID
299 Scan_Reserved_Identifier
(Force_Msg
=> False);
301 -- Not a reserved identifier after all (or at least we can't
302 -- be sure that it is), so reset the scan and continue.
305 Restore_Scan_State
(Scan_State
); -- back to the reserved word
309 -- Now look to see what kind of statement we have
313 -- Case of end or EOF
318 -- These tokens always terminate the statement sequence
320 Test_Statement_Required
;
327 -- Terminate if Eftm set or if the ELSIF is to the left
328 -- of the expected column of the end for this sequence
331 or else Start_Column
< Scopes
(Scope
.Last
).Ecol
333 Test_Statement_Required
;
336 -- Otherwise complain and skip past ELSIF Condition then
339 Error_Msg_SC
("ELSIF not allowed here");
341 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
343 Statement_Required
:= False;
350 -- Terminate if Eltm set or if the else is to the left
351 -- of the expected column of the end for this sequence
354 or else Start_Column
< Scopes
(Scope
.Last
).Ecol
356 Test_Statement_Required
;
359 -- Otherwise complain and skip past else
362 Error_Msg_SC
("ELSE not allowed here");
364 Statement_Required
:= False;
369 when Tok_Exception
=>
370 Test_Statement_Required
;
372 -- If Extm not set and the exception is not to the left of
373 -- the expected column of the end for this sequence, then we
374 -- assume it belongs to the current sequence, even though it
377 if not SS_Flags
.Extm
and then
378 Start_Column
>= Scopes
(Scope
.Last
).Ecol
381 Error_Msg_SC
("exception handler not permitted here");
382 Scan
; -- past EXCEPTION
383 Discard_Junk_List
(Parse_Exception_Handlers
);
386 -- Always return, in the case where we scanned out handlers
387 -- that we did not expect, Parse_Exception_Handlers returned
388 -- with Token being either end or EOF, so we are OK.
396 -- Terminate if Ortm set or if the or is to the left of the
397 -- expected column of the end for this sequence.
400 or else Start_Column
< Scopes
(Scope
.Last
).Ecol
402 Test_Statement_Required
;
405 -- Otherwise complain and skip past or
408 Error_Msg_SC
("OR not allowed here");
410 Statement_Required
:= False;
413 -- Case of THEN (deal also with THEN ABORT)
416 Save_Scan_State
(Scan_State
); -- at THEN
419 -- Terminate if THEN ABORT allowed (ATC case)
421 exit when SS_Flags
.Tatm
and then Token
= Tok_Abort
;
423 -- Otherwise we treat THEN as some kind of mess where we did
424 -- not see the associated IF, but we pick up assuming it had
427 Restore_Scan_State
(Scan_State
); -- to THEN
428 Append_To
(Statement_List
, P_If_Statement
);
429 Statement_Required
:= False;
431 -- Case of WHEN (error because we are not in a case)
436 -- Terminate if Whtm set or if the WHEN is to the left of
437 -- the expected column of the end for this sequence.
440 or else Start_Column
< Scopes
(Scope
.Last
).Ecol
442 Test_Statement_Required
;
445 -- Otherwise complain and skip when Choice {| Choice} =>
448 Error_Msg_SC
("WHEN not allowed here");
450 Discard_Junk_List
(P_Discrete_Choice_List
);
452 Statement_Required
:= False;
455 -- Cases of statements starting with an identifier
457 when Tok_Identifier
=>
460 -- Save scan pointers and line number in case block label
462 Id_Node
:= Token_Node
;
463 Block_Label
:= Token_Name
;
464 Save_Scan_State
(Scan_State_Label
); -- at possible label
467 -- Check for common case of assignment, since it occurs
468 -- frequently, and we want to process it efficiently.
470 if Token
= Tok_Colon_Equal
then
471 Scan
; -- past the colon-equal
472 Append_To
(Statement_List
,
473 P_Assignment_Statement
(Id_Node
));
474 Statement_Required
:= False;
476 -- Check common case of procedure call, another case that
477 -- we want to speed up as much as possible.
479 elsif Token
= Tok_Semicolon
then
480 Change_Name_To_Procedure_Call_Statement
(Id_Node
);
481 Append_To
(Statement_List
, Id_Node
);
482 Scan
; -- past semicolon
483 Statement_Required
:= False;
485 -- Here is the special test for a suspicious label, more
486 -- accurately a suspicious name, which we think perhaps
487 -- should have been a label. If next token is one of
488 -- LOOP, FOR, WHILE, DECLARE, BEGIN, then make an entry
489 -- in the suspicious label table.
491 if Token
= Tok_Loop
or else
492 Token
= Tok_For
or else
493 Token
= Tok_While
or else
494 Token
= Tok_Declare
or else
497 Suspicious_Labels
.Append
498 ((Proc_Call
=> Id_Node
,
499 Semicolon_Loc
=> Prev_Token_Ptr
,
500 Start_Token
=> Token_Ptr
));
503 -- Check for case of "go to" in place of "goto"
505 elsif Token
= Tok_Identifier
506 and then Block_Label
= Name_Go
507 and then Token_Name
= Name_To
509 Error_Msg_SP
-- CODEFIX
510 ("goto is one word");
511 Append_To
(Statement_List
, P_Goto_Statement
);
512 Statement_Required
:= False;
514 -- Check common case of = used instead of :=, just so we
515 -- give a better error message for this special misuse.
517 elsif Token
= Tok_Equal
then
518 T_Colon_Equal
; -- give := expected message
519 Append_To
(Statement_List
,
520 P_Assignment_Statement
(Id_Node
));
521 Statement_Required
:= False;
523 -- Check case of loop label or block label
525 elsif Token
= Tok_Colon
526 or else (Token
in Token_Class_Labeled_Stmt
527 and then not Token_Is_At_Start_Of_Line
)
529 T_Colon
; -- past colon (if there, or msg for missing one)
531 -- Test for more than one label
534 exit when Token
/= Tok_Identifier
;
535 Save_Scan_State
(Scan_State
); -- at second Id
538 if Token
= Tok_Colon
then
540 ("only one label allowed on block or loop");
541 Scan
; -- past colon on extra label
543 -- Use the second label as the "real" label
545 Scan_State_Label
:= Scan_State
;
547 -- We will set Error_name as the Block_Label since
548 -- we really don't know which of the labels might
549 -- be used at the end of the loop or block.
551 Block_Label
:= Error_Name
;
553 -- If Id with no colon, then backup to point to the
554 -- Id and we will issue the message below when we try
555 -- to scan out the statement as some other form.
558 Restore_Scan_State
(Scan_State
); -- to second Id
563 -- Loop_Statement (labeled Loop_Statement)
565 if Token
= Tok_Loop
then
566 Append_To
(Statement_List
,
567 P_Loop_Statement
(Id_Node
));
569 -- While statement (labeled loop statement with WHILE)
571 elsif Token
= Tok_While
then
572 Append_To
(Statement_List
,
573 P_While_Statement
(Id_Node
));
575 -- Declare statement (labeled block statement with
578 elsif Token
= Tok_Declare
then
579 Append_To
(Statement_List
,
580 P_Declare_Statement
(Id_Node
));
582 -- Begin statement (labeled block statement with no
585 elsif Token
= Tok_Begin
then
586 Append_To
(Statement_List
,
587 P_Begin_Statement
(Id_Node
));
589 -- For statement (labeled loop statement with FOR)
591 elsif Token
= Tok_For
then
592 Append_To
(Statement_List
,
593 P_For_Statement
(Id_Node
));
595 -- Otherwise complain we have inappropriate statement
599 ("loop or block statement must follow label");
602 Statement_Required
:= False;
604 -- Here we have an identifier followed by something
605 -- other than a colon, semicolon or assignment symbol.
606 -- The only valid possibility is a name extension symbol
608 elsif Token
in Token_Class_Namext
then
609 Restore_Scan_State
(Scan_State_Label
); -- to Id
612 -- Skip junk right parens in this context
614 Ignore
(Tok_Right_Paren
);
616 -- Check context following call
618 if Token
= Tok_Colon_Equal
then
619 Scan
; -- past colon equal
620 Append_To
(Statement_List
,
621 P_Assignment_Statement
(Name_Node
));
622 Statement_Required
:= False;
624 -- Check common case of = used instead of :=
626 elsif Token
= Tok_Equal
then
627 T_Colon_Equal
; -- give := expected message
628 Append_To
(Statement_List
,
629 P_Assignment_Statement
(Name_Node
));
630 Statement_Required
:= False;
632 -- Check apostrophe cases
634 elsif Token
= Tok_Apostrophe
then
635 Append_To
(Statement_List
,
636 P_Code_Statement
(Name_Node
));
637 Statement_Required
:= False;
639 -- The only other valid item after a name is ; which
640 -- means that the item we just scanned was a call.
642 elsif Token
= Tok_Semicolon
then
643 Change_Name_To_Procedure_Call_Statement
(Name_Node
);
644 Append_To
(Statement_List
, Name_Node
);
645 Scan
; -- past semicolon
646 Statement_Required
:= False;
648 -- A slash following an identifier or a selected
649 -- component in this situation is most likely a period
650 -- (see location of keys on keyboard).
652 elsif Token
= Tok_Slash
653 and then (Nkind
(Name_Node
) = N_Identifier
655 Nkind
(Name_Node
) = N_Selected_Component
)
657 Error_Msg_SC
-- CODEFIX
658 ("""/"" should be "".""");
659 Statement_Required
:= False;
662 -- Else we have a missing semicolon
667 -- Normal processing as though semicolon were present
669 Change_Name_To_Procedure_Call_Statement
(Name_Node
);
670 Append_To
(Statement_List
, Name_Node
);
671 Statement_Required
:= False;
674 -- If junk after identifier, check if identifier is an
675 -- instance of an incorrectly spelled keyword. If so, we
676 -- do nothing. The Bad_Spelling_Of will have reset Token
677 -- to the appropriate keyword, so the next time round the
678 -- loop we will process the modified token.
680 -- Note that we check for ELSIF before ELSE here, because
681 -- we don't want to identify a misspelling of ELSE as ELSIF,
682 -- and in particular we do not want to treat ELSEIF as
686 Restore_Scan_State
(Scan_State_Label
); -- to identifier
688 if Bad_Spelling_Of
(Tok_Abort
)
689 or else Bad_Spelling_Of
(Tok_Accept
)
690 or else Bad_Spelling_Of
(Tok_Case
)
691 or else Bad_Spelling_Of
(Tok_Declare
)
692 or else Bad_Spelling_Of
(Tok_Delay
)
693 or else Bad_Spelling_Of
(Tok_Elsif
)
694 or else Bad_Spelling_Of
(Tok_Else
)
695 or else Bad_Spelling_Of
(Tok_End
)
696 or else Bad_Spelling_Of
(Tok_Exception
)
697 or else Bad_Spelling_Of
(Tok_Exit
)
698 or else Bad_Spelling_Of
(Tok_For
)
699 or else Bad_Spelling_Of
(Tok_Goto
)
700 or else Bad_Spelling_Of
(Tok_If
)
701 or else Bad_Spelling_Of
(Tok_Loop
)
702 or else Bad_Spelling_Of
(Tok_Or
)
703 or else Bad_Spelling_Of
(Tok_Pragma
)
704 or else Bad_Spelling_Of
(Tok_Raise
)
705 or else Bad_Spelling_Of
(Tok_Requeue
)
706 or else Bad_Spelling_Of
(Tok_Return
)
707 or else Bad_Spelling_Of
(Tok_Select
)
708 or else Bad_Spelling_Of
(Tok_When
)
709 or else Bad_Spelling_Of
(Tok_While
)
713 -- If not a bad spelling, then we really have junk
716 Scan
; -- past identifier again
718 -- If next token is first token on line, then we
719 -- consider that we were missing a semicolon after
720 -- the identifier, and process it as a procedure
721 -- call with no parameters.
723 if Token_Is_At_Start_Of_Line
then
724 Change_Name_To_Procedure_Call_Statement
(Id_Node
);
725 Append_To
(Statement_List
, Id_Node
);
726 T_Semicolon
; -- to give error message
727 Statement_Required
:= False;
729 -- Otherwise we give a missing := message and
730 -- simply abandon the junk that is there now.
733 T_Colon_Equal
; -- give := expected message
740 -- Statement starting with operator symbol. This could be
741 -- a call, a name starting an assignment, or a qualified
744 when Tok_Operator_Symbol
=>
748 -- An attempt at a range attribute or a qualified expression
749 -- must be illegal here (a code statement cannot possibly
750 -- allow qualification by a function name).
752 if Token
= Tok_Apostrophe
then
753 Error_Msg_SC
("apostrophe illegal here");
757 -- Scan possible assignment if we have a name
759 if Expr_Form
= EF_Name
760 and then Token
= Tok_Colon_Equal
762 Scan
; -- past colon equal
763 Append_To
(Statement_List
,
764 P_Assignment_Statement
(Name_Node
));
766 Change_Name_To_Procedure_Call_Statement
(Name_Node
);
767 Append_To
(Statement_List
, Name_Node
);
771 Statement_Required
:= False;
773 -- Label starting with << which must precede real statement
774 -- Note: in Ada 2012, the label may end the sequence.
776 when Tok_Less_Less
=>
777 if Present
(Last
(Statement_List
))
778 and then Nkind
(Last
(Statement_List
)) /= N_Label
780 Statement_Seen
:= True;
783 Append_To
(Statement_List
, P_Label
);
784 Statement_Required
:= True;
786 if No
(Label_Loc
) then
787 Label_Loc
:= Sloc
(Last
(Statement_List
));
790 -- Pragma appearing as a statement in a statement sequence
794 Append_To
(Statement_List
, P_Pragma
);
800 Append_To
(Statement_List
, P_Abort_Statement
);
801 Statement_Required
:= False;
807 Append_To
(Statement_List
, P_Accept_Statement
);
808 Statement_Required
:= False;
810 -- Begin_Statement (Block_Statement with no declare, no label)
814 Append_To
(Statement_List
, P_Begin_Statement
);
815 Statement_Required
:= False;
821 Append_To
(Statement_List
, P_Case_Statement
);
822 Statement_Required
:= False;
824 -- Block_Statement with DECLARE and no label
828 Append_To
(Statement_List
, P_Declare_Statement
);
829 Statement_Required
:= False;
835 Append_To
(Statement_List
, P_Delay_Statement
);
836 Statement_Required
:= False;
842 Append_To
(Statement_List
, P_Exit_Statement
);
843 Statement_Required
:= False;
845 -- Loop_Statement with FOR and no label
849 Append_To
(Statement_List
, P_For_Statement
);
850 Statement_Required
:= False;
856 Append_To
(Statement_List
, P_Goto_Statement
);
857 Statement_Required
:= False;
863 Append_To
(Statement_List
, P_If_Statement
);
864 Statement_Required
:= False;
870 Append_To
(Statement_List
, P_Loop_Statement
);
871 Statement_Required
:= False;
877 Append_To
(Statement_List
, P_Null_Statement
);
878 Statement_Required
:= False;
884 Append_To
(Statement_List
, P_Raise_Statement
);
885 Statement_Required
:= False;
891 Append_To
(Statement_List
, P_Requeue_Statement
);
892 Statement_Required
:= False;
898 Append_To
(Statement_List
, P_Return_Statement
);
899 Statement_Required
:= False;
905 Append_To
(Statement_List
, P_Select_Statement
);
906 Statement_Required
:= False;
908 -- While_Statement (Block_Statement with while and no loop)
912 Append_To
(Statement_List
, P_While_Statement
);
913 Statement_Required
:= False;
915 -- Anything else is some kind of junk, signal an error message
916 -- and then raise Error_Resync, to merge with the normal
917 -- handling of a bad statement.
920 Error_Msg_BC
-- CODEFIX
921 ("statement expected");
925 -- On error resynchronization, skip past next semicolon, and, since
926 -- we are still in the statement loop, look for next statement. We
927 -- set Statement_Required False to avoid an unnecessary error message
928 -- complaining that no statement was found (i.e. we consider the
929 -- junk to satisfy the requirement for a statement being present).
933 Resync_Past_Semicolon_Or_To_Loop_Or_Then
;
934 Statement_Required
:= False;
937 exit when SS_Flags
.Unco
;
940 -- If there are no declarative items in the list, or if the list is part
941 -- of a handled sequence of statements, we just return the list.
942 -- Otherwise, we wrap the list in a block statement, so the declarations
943 -- will have a proper scope. In the Handled case, it would be wrong to
944 -- wrap, because we want the code before and after "begin" to be in the
945 -- same scope. Example:
949 -- Do_Something (...);
952 -- is tranformed into:
957 -- Do_Something (...);
961 -- But we don't wrap this:
968 -- Otherwise, we would fail to detect the error (conflicting X's).
969 -- Similarly, if a representation clause appears in the statement
970 -- part, we don't want it to appear more nested than the declarative
971 -- part -- that would cause an unwanted error.
973 if Present
(Decl_Loc
) then
974 -- Forbid labels and declarative items from coexisting. Otherwise,
975 -- one could jump past a declaration, leading to chaos. Jumping
976 -- backward past a declaration is also questionable -- does the
977 -- declaration get elaborated again? Is secondary stack storage
978 -- reclaimed? (A more liberal rule was proposed, but this is what
979 -- we're doing for now.)
981 if Present
(Label_Loc
) then
982 Error_Msg
("declarative item in same list as label", Decl_Loc
);
983 Error_Msg
("label in same list as declarative item", Label_Loc
);
986 -- Forbid exception handlers and declarative items from
987 -- coexisting. Example:
989 -- X : Integer := 123;
992 -- X : Integer := 456;
998 -- It was proposed that in the handler, X should refer to the outer
999 -- X, but that's just confusing.
1001 if Token
= Tok_Exception
then
1003 ("declarative item in statements conflicts with " &
1004 "exception handler below",
1007 ("exception handler conflicts with " &
1008 "declarative item in statements above",
1013 return Statement_List
;
1016 Loc
: constant Source_Ptr
:= Sloc
(First
(Statement_List
));
1017 Block
: constant Node_Id
:=
1018 Make_Block_Statement
1020 Handled_Statement_Sequence
=>
1021 Make_Handled_Sequence_Of_Statements
1022 (Loc
, Statements
=> Statement_List
));
1024 return New_List
(Block
);
1028 return Statement_List
;
1030 end P_Sequence_Of_Statements
;
1032 --------------------
1034 --------------------
1036 ---------------------------
1037 -- 5.1 Simple Statement --
1038 ---------------------------
1040 -- Parsed by P_Sequence_Of_Statements (5.1)
1042 -----------------------------
1043 -- 5.1 Compound Statement --
1044 -----------------------------
1046 -- Parsed by P_Sequence_Of_Statements (5.1)
1048 -------------------------
1049 -- 5.1 Null Statement --
1050 -------------------------
1052 -- NULL_STATEMENT ::= null;
1054 -- The caller has already checked that the current token is null
1056 -- Error recovery: cannot raise Error_Resync
1058 function P_Null_Statement
return Node_Id
is
1059 Null_Stmt_Node
: Node_Id
;
1062 Null_Stmt_Node
:= New_Node
(N_Null_Statement
, Token_Ptr
);
1065 return Null_Stmt_Node
;
1066 end P_Null_Statement
;
1072 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
1074 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
1076 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
1077 -- (not an OPERATOR_SYMBOL)
1079 -- The caller has already checked that the current token is <<
1081 -- Error recovery: can raise Error_Resync
1083 function P_Label
return Node_Id
is
1084 Label_Node
: Node_Id
;
1087 Label_Node
:= New_Node
(N_Label
, Token_Ptr
);
1089 Set_Identifier
(Label_Node
, P_Identifier
(C_Greater_Greater
));
1091 Append_Elmt
(Label_Node
, Label_List
);
1095 -------------------------------
1096 -- 5.1 Statement Identifier --
1097 -------------------------------
1099 -- Statement label is parsed by P_Label (5.1)
1101 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1102 -- or P_While_Statement (5.5)
1104 -- Block label is parsed by P_Begin_Statement (5.6) or
1105 -- P_Declare_Statement (5.6)
1107 -------------------------------
1108 -- 5.2 Assignment Statement --
1109 -------------------------------
1111 -- ASSIGNMENT_STATEMENT ::=
1112 -- variable_NAME := EXPRESSION;
1114 -- Error recovery: can raise Error_Resync
1116 function P_Assignment_Statement
(LHS
: Node_Id
) return Node_Id
is
1117 Assign_Node
: Node_Id
;
1120 Assign_Node
:= New_Node
(N_Assignment_Statement
, Prev_Token_Ptr
);
1121 Current_Assign_Node
:= Assign_Node
;
1122 Set_Name
(Assign_Node
, LHS
);
1123 Set_Expression
(Assign_Node
, P_Expression_No_Right_Paren
);
1125 Current_Assign_Node
:= Empty
;
1127 end P_Assignment_Statement
;
1129 -----------------------
1130 -- 5.3 If Statement --
1131 -----------------------
1134 -- if CONDITION then
1135 -- SEQUENCE_OF_STATEMENTS
1136 -- {elsif CONDITION then
1137 -- SEQUENCE_OF_STATEMENTS}
1139 -- SEQUENCE_OF_STATEMENTS]
1142 -- The caller has checked that the initial token is IF (or in the error
1143 -- case of a mysterious THEN, the initial token may simply be THEN, in
1144 -- which case, no condition (or IF) was scanned).
1146 -- Error recovery: can raise Error_Resync
1148 function P_If_Statement
return Node_Id
is
1150 Elsif_Node
: Node_Id
;
1153 procedure Add_Elsif_Part
;
1154 -- An internal procedure used to scan out a single ELSIF part. On entry
1155 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1156 -- scanned out and is in Prev_Token.
1158 procedure Check_If_Column
;
1159 -- An internal procedure used to check that THEN, ELSE, or ELSIF
1160 -- appear in the right place if column checking is enabled (i.e. if
1161 -- they are the first token on the line, then they must appear in
1162 -- the same column as the opening IF).
1164 procedure Check_Then_Column
;
1165 -- This procedure carries out the style checks for a THEN token
1166 -- Note that the caller has set Loc to the Source_Ptr value for
1167 -- the previous IF or ELSIF token.
1169 function Else_Should_Be_Elsif
return Boolean;
1170 -- An internal routine used to do a special error recovery check when
1171 -- an ELSE is encountered. It determines if the ELSE should be treated
1172 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1173 -- is followed by a sequence of tokens, starting on the same line as
1174 -- the ELSE, which are not expression terminators, followed by a THEN.
1175 -- On entry, the ELSE has been scanned out.
1177 procedure Add_Elsif_Part
is
1179 if No
(Elsif_Parts
(If_Node
)) then
1180 Set_Elsif_Parts
(If_Node
, New_List
);
1183 Elsif_Node
:= New_Node
(N_Elsif_Part
, Prev_Token_Ptr
);
1184 Loc
:= Prev_Token_Ptr
;
1185 Set_Condition
(Elsif_Node
, P_Condition
);
1189 (Elsif_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1190 Append
(Elsif_Node
, Elsif_Parts
(If_Node
));
1193 procedure Check_If_Column
is
1195 if RM_Column_Check
and then Token_Is_At_Start_Of_Line
1196 and then Start_Column
/= Scopes
(Scope
.Last
).Ecol
1198 Error_Msg_Col
:= Scopes
(Scope
.Last
).Ecol
;
1199 Error_Msg_SC
("(style) this token should be@?l?");
1201 end Check_If_Column
;
1203 procedure Check_Then_Column
is
1205 if Token
= Tok_Then
then
1209 Style
.Check_Then
(Loc
);
1212 end Check_Then_Column
;
1214 function Else_Should_Be_Elsif
return Boolean is
1215 Scan_State
: Saved_Scan_State
;
1218 if Token_Is_At_Start_Of_Line
then
1222 Save_Scan_State
(Scan_State
);
1225 if Token
in Token_Class_Eterm
then
1226 Restore_Scan_State
(Scan_State
);
1229 Scan
; -- past non-expression terminating token
1231 if Token
= Tok_Then
then
1232 Restore_Scan_State
(Scan_State
);
1238 end Else_Should_Be_Elsif
;
1240 -- Start of processing for P_If_Statement
1243 If_Node
:= New_Node
(N_If_Statement
, Token_Ptr
);
1246 Scopes
(Scope
.Last
).Etyp
:= E_If
;
1247 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
1248 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
1249 Scopes
(Scope
.Last
).Labl
:= Error
;
1250 Scopes
(Scope
.Last
).Node
:= If_Node
;
1252 if Token
= Tok_If
then
1255 Set_Condition
(If_Node
, P_Condition
);
1257 -- Deal with misuse of IF expression => used instead
1258 -- of WHEN expression =>
1260 if Token
= Tok_Arrow
then
1261 Error_Msg_SC
-- CODEFIX
1263 Scan
; -- past the arrow
1264 Pop_Scope_Stack
; -- remove unneeded entry
1271 Error_Msg_SC
("no IF for this THEN");
1272 Set_Condition
(If_Node
, Error
);
1278 (If_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1280 -- This loop scans out else and elsif parts
1283 if Token
= Tok_Elsif
then
1286 if Present
(Else_Statements
(If_Node
)) then
1287 Error_Msg_SP
("ELSIF cannot appear after ELSE");
1293 elsif Token
= Tok_Else
then
1297 if Else_Should_Be_Elsif
then
1298 Error_Msg_SP
-- CODEFIX
1299 ("ELSE should be ELSIF");
1303 -- Here we have an else that really is an else
1305 if Present
(Else_Statements
(If_Node
)) then
1306 Error_Msg_SP
("only one ELSE part allowed");
1308 (P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
),
1309 Else_Statements
(If_Node
));
1312 (If_Node
, P_Sequence_Of_Statements
(SS_Eftm_Eltm_Sreq
));
1316 -- If anything other than ELSE or ELSIF, exit the loop. The token
1317 -- had better be END (and in fact it had better be END IF), but
1318 -- we will let End_Statements take care of checking that.
1330 --------------------
1332 --------------------
1334 -- CONDITION ::= boolean_EXPRESSION
1336 function P_Condition
return Node_Id
is
1338 return P_Condition
(P_Expression_No_Right_Paren
);
1341 function P_Condition
(Cond
: Node_Id
) return Node_Id
is
1343 -- It is never possible for := to follow a condition, so if we get
1344 -- a := we assume it is a mistyped equality. Note that we do not try
1345 -- to reconstruct the tree correctly in this case, but we do at least
1346 -- give an accurate error message.
1348 if Token
= Tok_Colon_Equal
then
1349 while Token
= Tok_Colon_Equal
loop
1350 Error_Msg_SC
-- CODEFIX
1351 (""":="" should be ""=""");
1352 Scan
; -- past junk :=
1353 Discard_Junk_Node
(P_Expression_No_Right_Paren
);
1358 -- Otherwise check for redundant parentheses
1362 Style
.Check_Xtra_Parens
(Cond
);
1364 -- When the condition is an operator then examine parentheses
1365 -- surrounding the condition's operands - taking care to avoid
1366 -- flagging operands which themselves are operators since they
1367 -- may be required for resolution or precedence.
1369 if Nkind
(Cond
) in N_Op
1372 and then Nkind
(Right_Opnd
(Cond
)) not in N_Op
1376 Style
.Check_Xtra_Parens
(Right_Opnd
(Cond
));
1379 if Nkind
(Cond
) in N_Binary_Op
1382 and then Nkind
(Left_Opnd
(Cond
)) not in N_Op
1386 Style
.Check_Xtra_Parens
(Left_Opnd
(Cond
));
1390 -- And return the result
1396 -------------------------
1397 -- 5.4 Case Statement --
1398 -------------------------
1400 -- CASE_STATEMENT ::=
1401 -- case EXPRESSION is
1402 -- CASE_STATEMENT_ALTERNATIVE
1403 -- {CASE_STATEMENT_ALTERNATIVE}
1406 -- The caller has checked that the first token is CASE
1408 -- Can raise Error_Resync
1410 function P_Case_Statement
return Node_Id
is
1411 Case_Node
: Node_Id
;
1413 Alternatives_List
: List_Id
;
1414 First_When_Loc
: Source_Ptr
;
1417 Case_Node
:= New_Node
(N_Case_Statement
, Token_Ptr
);
1420 Scopes
(Scope
.Last
).Etyp
:= E_Case
;
1421 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
1422 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
1423 Scopes
(Scope
.Last
).Labl
:= Error
;
1424 Scopes
(Scope
.Last
).Node
:= Case_Node
;
1428 Expr
:= P_Expression_No_Right_Paren
;
1431 Style
.Check_Xtra_Parens
(Expr
);
1434 Set_Expression
(Case_Node
, Expr
);
1437 -- Prepare to parse case statement alternatives
1439 Alternatives_List
:= New_List
;
1440 P_Pragmas_Opt
(Alternatives_List
);
1441 First_When_Loc
:= Token_Ptr
;
1443 -- Loop through case statement alternatives
1446 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1447 -- that it is a semantic check to ensure the proper use of OTHERS
1449 if Token
in Tok_When | Tok_Others
then
1450 Append
(P_Case_Statement_Alternative
, Alternatives_List
);
1452 -- If we have an END, then probably we are at the end of the case
1453 -- but we only exit if Check_End thinks the END was reasonable.
1455 elsif Token
= Tok_End
then
1456 exit when Check_End
;
1458 -- Here if token is other than WHEN, OTHERS or END. We definitely
1459 -- have an error, but the question is whether or not to get out of
1460 -- the case statement. We don't want to get out early, or we will
1461 -- get a slew of junk error messages for subsequent when tokens.
1463 -- If the token is not at the start of the line, or if it is indented
1464 -- with respect to the current case statement, then the best guess is
1465 -- that we are still supposed to be inside the case statement. We
1466 -- complain about the missing WHEN, and discard the junk statements.
1468 elsif not Token_Is_At_Start_Of_Line
1469 or else Start_Column
> Scopes
(Scope
.Last
).Ecol
1471 Error_Msg_BC
("WHEN (case statement alternative) expected");
1473 -- Here is a possibility for infinite looping if we don't make
1474 -- progress. So try to process statements, otherwise exit
1477 Error_Ptr
: constant Source_Ptr
:= Scan_Ptr
;
1479 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_Whtm
));
1480 exit when Scan_Ptr
= Error_Ptr
and then Check_End
;
1483 -- Here we have a junk token at the start of the line and it is
1484 -- not indented. If Check_End thinks there is a missing END, then
1485 -- we will get out of the case, otherwise we keep going.
1488 exit when Check_End
;
1492 -- Make sure we have at least one alternative
1494 if No
(First_Non_Pragma
(Alternatives_List
)) then
1496 ("WHEN expected, must have at least one alternative in case",
1501 Set_Alternatives
(Case_Node
, Alternatives_List
);
1504 end P_Case_Statement
;
1506 -------------------------------------
1507 -- 5.4 Case Statement Alternative --
1508 -------------------------------------
1510 -- CASE_STATEMENT_ALTERNATIVE ::=
1511 -- when DISCRETE_CHOICE_LIST =>
1512 -- SEQUENCE_OF_STATEMENTS
1514 -- The caller has checked that the initial token is WHEN or OTHERS
1515 -- Error recovery: can raise Error_Resync
1517 function P_Case_Statement_Alternative
return Node_Id
is
1518 Case_Alt_Node
: Node_Id
;
1522 Style
.Check_Indentation
;
1525 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Token_Ptr
);
1526 T_When
; -- past WHEN (or give error in OTHERS case)
1527 Set_Discrete_Choices
(Case_Alt_Node
, P_Discrete_Choice_List
);
1529 Set_Statements
(Case_Alt_Node
, P_Sequence_Of_Statements
(SS_Sreq_Whtm
));
1530 return Case_Alt_Node
;
1531 end P_Case_Statement_Alternative
;
1533 -------------------------
1534 -- 5.5 Loop Statement --
1535 -------------------------
1537 -- LOOP_STATEMENT ::=
1538 -- [LOOP_STATEMENT_IDENTIFIER:]
1539 -- [ITERATION_SCHEME] loop
1540 -- SEQUENCE_OF_STATEMENTS
1541 -- end loop [loop_IDENTIFIER];
1543 -- ITERATION_SCHEME ::=
1545 -- | for LOOP_PARAMETER_SPECIFICATION
1547 -- The parsing of loop statements is handled by one of three functions
1548 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1549 -- on the initial keyword in the construct (excluding the identifier)
1553 -- This function parses the case where no iteration scheme is present
1555 -- The caller has checked that the initial token is LOOP. The parameter
1556 -- is the node identifiers for the loop label if any (or is set to Empty
1557 -- if there is no loop label).
1559 -- Error recovery : cannot raise Error_Resync
1561 function P_Loop_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1562 Loop_Node
: Node_Id
;
1563 Created_Name
: Node_Id
;
1567 Scopes
(Scope
.Last
).Labl
:= Loop_Name
;
1568 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
1569 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
1570 Scopes
(Scope
.Last
).Etyp
:= E_Loop
;
1572 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1575 if No
(Loop_Name
) then
1577 Make_Identifier
(Sloc
(Loop_Node
), Set_Loop_Block_Name
('L'));
1578 Set_Comes_From_Source
(Created_Name
, False);
1579 Set_Has_Created_Identifier
(Loop_Node
, True);
1580 Set_Identifier
(Loop_Node
, Created_Name
);
1581 Scopes
(Scope
.Last
).Labl
:= Created_Name
;
1583 Set_Identifier
(Loop_Node
, Loop_Name
);
1586 Append_Elmt
(Loop_Node
, Label_List
);
1587 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1588 End_Statements
(Loop_Node
);
1590 end P_Loop_Statement
;
1594 -- This function parses a loop statement with a FOR iteration scheme
1596 -- The caller has checked that the initial token is FOR. The parameter
1597 -- is the node identifier for the block label if any (or is set to Empty
1598 -- if there is no block label).
1600 -- Note: the caller fills in the Identifier field if a label was present
1602 -- Error recovery: can raise Error_Resync
1604 function P_For_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1605 Loop_Node
: Node_Id
;
1606 Iter_Scheme_Node
: Node_Id
;
1607 Loop_For_Flag
: Boolean;
1608 Created_Name
: Node_Id
;
1613 Scopes
(Scope
.Last
).Labl
:= Loop_Name
;
1614 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
1615 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
1616 Scopes
(Scope
.Last
).Etyp
:= E_Loop
;
1618 Loop_For_Flag
:= (Prev_Token
= Tok_Loop
);
1620 Iter_Scheme_Node
:= New_Node
(N_Iteration_Scheme
, Token_Ptr
);
1621 Spec
:= P_Loop_Parameter_Specification
;
1623 if Nkind
(Spec
) = N_Loop_Parameter_Specification
then
1624 Set_Loop_Parameter_Specification
(Iter_Scheme_Node
, Spec
);
1626 Set_Iterator_Specification
(Iter_Scheme_Node
, Spec
);
1629 -- The following is a special test so that a miswritten for loop such
1630 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1631 -- entry in the scope stack. We don't bother to actually fix up the
1632 -- tree in this case since it's not worth the effort. Instead we just
1633 -- eat up the loop junk, leaving the entry for what now looks like an
1634 -- unmodified loop intact.
1636 if Loop_For_Flag
and then Token
= Tok_Semicolon
then
1637 Error_Msg_SC
("LOOP belongs here, not before FOR");
1644 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1646 if No
(Loop_Name
) then
1648 Make_Identifier
(Sloc
(Loop_Node
), Set_Loop_Block_Name
('L'));
1649 Set_Comes_From_Source
(Created_Name
, False);
1650 Set_Has_Created_Identifier
(Loop_Node
, True);
1651 Set_Identifier
(Loop_Node
, Created_Name
);
1652 Scopes
(Scope
.Last
).Labl
:= Created_Name
;
1654 Set_Identifier
(Loop_Node
, Loop_Name
);
1658 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1659 End_Statements
(Loop_Node
);
1660 Set_Iteration_Scheme
(Loop_Node
, Iter_Scheme_Node
);
1661 Append_Elmt
(Loop_Node
, Label_List
);
1664 end P_For_Statement
;
1666 -- P_While_Statement
1668 -- This procedure scans a loop statement with a WHILE iteration scheme
1670 -- The caller has checked that the initial token is WHILE. The parameter
1671 -- is the node identifier for the block label if any (or is set to Empty
1672 -- if there is no block label).
1674 -- Error recovery: cannot raise Error_Resync
1676 function P_While_Statement
(Loop_Name
: Node_Id
:= Empty
) return Node_Id
is
1677 Loop_Node
: Node_Id
;
1678 Iter_Scheme_Node
: Node_Id
;
1679 Loop_While_Flag
: Boolean;
1680 Created_Name
: Node_Id
;
1684 Scopes
(Scope
.Last
).Labl
:= Loop_Name
;
1685 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
1686 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
1687 Scopes
(Scope
.Last
).Etyp
:= E_Loop
;
1689 Loop_While_Flag
:= (Prev_Token
= Tok_Loop
);
1690 Iter_Scheme_Node
:= New_Node
(N_Iteration_Scheme
, Token_Ptr
);
1692 Set_Condition
(Iter_Scheme_Node
, P_Condition
);
1694 -- The following is a special test so that a miswritten for loop such
1695 -- as "loop while I > 10;" is handled nicely, without making an extra
1696 -- entry in the scope stack. We don't bother to actually fix up the
1697 -- tree in this case since it's not worth the effort. Instead we just
1698 -- eat up the loop junk, leaving the entry for what now looks like an
1699 -- unmodified loop intact.
1701 if Loop_While_Flag
and then Token
= Tok_Semicolon
then
1702 Error_Msg_SC
("LOOP belongs here, not before WHILE");
1709 Loop_Node
:= New_Node
(N_Loop_Statement
, Token_Ptr
);
1712 if No
(Loop_Name
) then
1714 Make_Identifier
(Sloc
(Loop_Node
), Set_Loop_Block_Name
('L'));
1715 Set_Comes_From_Source
(Created_Name
, False);
1716 Set_Has_Created_Identifier
(Loop_Node
, True);
1717 Set_Identifier
(Loop_Node
, Created_Name
);
1718 Scopes
(Scope
.Last
).Labl
:= Created_Name
;
1720 Set_Identifier
(Loop_Node
, Loop_Name
);
1723 Set_Statements
(Loop_Node
, P_Sequence_Of_Statements
(SS_Sreq
));
1724 End_Statements
(Loop_Node
);
1725 Set_Iteration_Scheme
(Loop_Node
, Iter_Scheme_Node
);
1726 Append_Elmt
(Loop_Node
, Label_List
);
1729 end P_While_Statement
;
1731 ---------------------------------------
1732 -- 5.5 Loop Parameter Specification --
1733 ---------------------------------------
1735 -- LOOP_PARAMETER_SPECIFICATION ::=
1736 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1737 -- [Iterator_Filter]
1739 -- Error recovery: cannot raise Error_Resync
1741 function P_Loop_Parameter_Specification
return Node_Id
is
1742 Loop_Param_Specification_Node
: Node_Id
;
1745 Scan_State
: Saved_Scan_State
;
1749 Save_Scan_State
(Scan_State
);
1750 ID_Node
:= P_Defining_Identifier
(C_In
);
1752 -- If the next token is OF, it indicates an Ada 2012 iterator. If the
1753 -- next token is a colon, this is also an Ada 2012 iterator, including
1754 -- a subtype indication for the loop parameter. Otherwise we parse the
1755 -- construct as a loop parameter specification. Note that the form
1756 -- "for A in B" is ambiguous, and must be resolved semantically: if B
1757 -- is a discrete subtype this is a loop specification, but if it is an
1758 -- expression it is an iterator specification. Ambiguity is resolved
1759 -- during analysis of the loop parameter specification.
1761 if Token
in Tok_Of | Tok_Colon
then
1762 Error_Msg_Ada_2012_Feature
("iterator", Token_Ptr
);
1763 return P_Iterator_Specification
(ID_Node
);
1766 -- The span of the Loop_Parameter_Specification starts at the
1767 -- defining identifier.
1769 Loop_Param_Specification_Node
:=
1770 New_Node
(N_Loop_Parameter_Specification
, Sloc
(ID_Node
));
1771 Set_Defining_Identifier
(Loop_Param_Specification_Node
, ID_Node
);
1773 if Token
= Tok_Left_Paren
then
1774 Error_Msg_SC
("subscripted loop parameter not allowed");
1775 Restore_Scan_State
(Scan_State
);
1776 Discard_Junk_Node
(P_Name
);
1778 elsif Token
= Tok_Dot
then
1779 Error_Msg_SC
("selected loop parameter not allowed");
1780 Restore_Scan_State
(Scan_State
);
1781 Discard_Junk_Node
(P_Name
);
1786 if Token
= Tok_Reverse
then
1787 Scan
; -- past REVERSE
1788 Set_Reverse_Present
(Loop_Param_Specification_Node
, True);
1791 Set_Discrete_Subtype_Definition
1792 (Loop_Param_Specification_Node
, P_Discrete_Subtype_Definition
);
1794 if Token
= Tok_When
then
1795 Error_Msg_Ada_2022_Feature
("iterator filter", Token_Ptr
);
1799 (Loop_Param_Specification_Node
, P_Condition
);
1802 return Loop_Param_Specification_Node
;
1805 when Error_Resync
=>
1807 end P_Loop_Parameter_Specification
;
1809 ----------------------------------
1810 -- 5.5.1 Iterator_Specification --
1811 ----------------------------------
1813 function P_Iterator_Specification
(Def_Id
: Node_Id
) return Node_Id
is
1817 Node1
:= New_Node
(N_Iterator_Specification
, Sloc
(Def_Id
));
1818 Set_Defining_Identifier
(Node1
, Def_Id
);
1820 if Token
= Tok_Colon
then
1823 if Token
= Tok_Access
then
1824 Error_Msg_Ada_2022_Feature
1825 ("access definition in loop parameter", Token_Ptr
);
1826 Set_Subtype_Indication
(Node1
, P_Access_Definition
(False));
1829 Set_Subtype_Indication
(Node1
, P_Subtype_Indication
);
1833 if Token
= Tok_Of
then
1834 Set_Of_Present
(Node1
);
1837 elsif Token
= Tok_In
then
1840 elsif Prev_Token
= Tok_In
1841 and then Present
(Subtype_Indication
(Node1
))
1843 -- Simplest recovery is to transform it into an element iterator.
1844 -- Error message on 'in" has already been emitted when parsing the
1845 -- optional constraint.
1847 Set_Of_Present
(Node1
);
1849 ("subtype indication is only legal on an element iterator",
1850 Subtype_Indication
(Node1
));
1856 if Token
= Tok_Reverse
then
1857 Scan
; -- past REVERSE
1858 Set_Reverse_Present
(Node1
, True);
1861 Set_Name
(Node1
, P_Name
);
1863 if Token
= Tok_When
then
1864 Error_Msg_Ada_2022_Feature
("iterator filter", Token_Ptr
);
1868 (Node1
, P_Condition
);
1872 end P_Iterator_Specification
;
1874 --------------------------
1875 -- 5.6 Block Statement --
1876 --------------------------
1878 -- BLOCK_STATEMENT ::=
1879 -- [block_STATEMENT_IDENTIFIER:]
1881 -- DECLARATIVE_PART]
1883 -- HANDLED_SEQUENCE_OF_STATEMENTS
1884 -- end [block_IDENTIFIER];
1886 -- The parsing of block statements is handled by one of the two functions
1887 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1888 -- a declare section is present
1890 -- P_Declare_Statement
1892 -- This function parses a block statement with DECLARE present
1894 -- The caller has checked that the initial token is DECLARE
1896 -- Error recovery: cannot raise Error_Resync
1898 function P_Declare_Statement
1899 (Block_Name
: Node_Id
:= Empty
)
1902 Block_Node
: Node_Id
;
1903 Created_Name
: Node_Id
;
1906 Block_Node
:= New_Node
(N_Block_Statement
, Token_Ptr
);
1909 Scopes
(Scope
.Last
).Etyp
:= E_Name
;
1910 Scopes
(Scope
.Last
).Lreq
:= Present
(Block_Name
);
1911 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
1912 Scopes
(Scope
.Last
).Labl
:= Block_Name
;
1913 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
1915 Scan
; -- past DECLARE
1917 if No
(Block_Name
) then
1919 Make_Identifier
(Sloc
(Block_Node
), Set_Loop_Block_Name
('B'));
1920 Set_Comes_From_Source
(Created_Name
, False);
1921 Set_Has_Created_Identifier
(Block_Node
, True);
1922 Set_Identifier
(Block_Node
, Created_Name
);
1923 Scopes
(Scope
.Last
).Labl
:= Created_Name
;
1925 Set_Identifier
(Block_Node
, Block_Name
);
1928 Append_Elmt
(Block_Node
, Label_List
);
1929 Parse_Decls_Begin_End
(Block_Node
);
1931 end P_Declare_Statement
;
1933 -- P_Begin_Statement
1935 -- This function parses a block statement with no DECLARE present
1937 -- The caller has checked that the initial token is BEGIN
1939 -- Error recovery: cannot raise Error_Resync
1941 function P_Begin_Statement
1942 (Block_Name
: Node_Id
:= Empty
)
1945 Block_Node
: Node_Id
;
1946 Created_Name
: Node_Id
;
1949 Block_Node
:= New_Node
(N_Block_Statement
, Token_Ptr
);
1952 Scopes
(Scope
.Last
).Etyp
:= E_Name
;
1953 Scopes
(Scope
.Last
).Lreq
:= Present
(Block_Name
);
1954 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
1955 Scopes
(Scope
.Last
).Labl
:= Block_Name
;
1956 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
1958 if No
(Block_Name
) then
1960 Make_Identifier
(Sloc
(Block_Node
), Set_Loop_Block_Name
('B'));
1961 Set_Comes_From_Source
(Created_Name
, False);
1962 Set_Has_Created_Identifier
(Block_Node
, True);
1963 Set_Identifier
(Block_Node
, Created_Name
);
1964 Scopes
(Scope
.Last
).Labl
:= Created_Name
;
1966 Set_Identifier
(Block_Node
, Block_Name
);
1969 Append_Elmt
(Block_Node
, Label_List
);
1971 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
1972 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
1974 Set_Handled_Statement_Sequence
1975 (Block_Node
, P_Handled_Sequence_Of_Statements
);
1976 End_Statements
(Handled_Statement_Sequence
(Block_Node
));
1978 end P_Begin_Statement
;
1980 -------------------------
1981 -- 5.7 Exit Statement --
1982 -------------------------
1984 -- EXIT_STATEMENT ::=
1985 -- exit [loop_NAME] [when CONDITION];
1987 -- The caller has checked that the initial token is EXIT
1989 -- Error recovery: can raise Error_Resync
1991 function P_Exit_Statement
return Node_Id
is
1992 Exit_Node
: Node_Id
;
1994 -- Start of processing for P_Exit_Statement
1997 Exit_Node
:= New_Node
(N_Exit_Statement
, Token_Ptr
);
2000 if Token
= Tok_Identifier
then
2001 Set_Name
(Exit_Node
, P_Qualified_Simple_Name
);
2003 elsif Style_Check
then
2004 -- This EXIT has no name, so check that
2005 -- the innermost loop is unnamed too.
2007 Check_No_Exit_Name
:
2008 for J
in reverse 1 .. Scope
.Last
loop
2009 if Scopes
(J
).Etyp
= E_Loop
then
2010 if Present
(Scopes
(J
).Labl
)
2011 and then Comes_From_Source
(Scopes
(J
).Labl
)
2013 -- Innermost loop in fact had a name, style check fails
2015 Style
.No_Exit_Name
(Scopes
(J
).Labl
);
2018 exit Check_No_Exit_Name
;
2020 end loop Check_No_Exit_Name
;
2023 if Token
= Tok_When
and then not Missing_Semicolon_On_When
then
2025 Set_Condition
(Exit_Node
, P_Condition
);
2027 -- Allow IF instead of WHEN, giving error message
2029 elsif Token
= Tok_If
then
2031 Scan
; -- past IF used in place of WHEN
2032 Set_Condition
(Exit_Node
, P_Expression_No_Right_Paren
);
2037 end P_Exit_Statement
;
2039 -------------------------
2040 -- 5.8 Goto Statement --
2041 -------------------------
2043 -- GOTO_STATEMENT ::= goto label_NAME;
2045 -- The caller has checked that the initial token is GOTO (or TO in the
2046 -- error case where GO and TO were incorrectly separated).
2048 -- Error recovery: can raise Error_Resync
2050 function P_Goto_Statement
return Node_Id
is
2051 Goto_Node
: Node_Id
;
2054 Goto_Node
:= New_Node
(N_Goto_Statement
, Token_Ptr
);
2055 Scan
; -- past GOTO (or TO)
2056 Set_Name
(Goto_Node
, P_Qualified_Simple_Name_Resync
);
2057 Append_Elmt
(Goto_Node
, Goto_List
);
2059 if Token
= Tok_When
then
2060 Error_Msg_GNAT_Extension
("goto when statement", Token_Ptr
);
2063 Mutate_Nkind
(Goto_Node
, N_Goto_When_Statement
);
2064 Set_Condition
(Goto_Node
, P_Expression_No_Right_Paren
);
2069 end P_Goto_Statement
;
2071 ---------------------------
2072 -- Parse_Decls_Begin_End --
2073 ---------------------------
2075 -- This function parses the construct:
2079 -- HANDLED_SEQUENCE_OF_STATEMENTS
2082 -- The caller has built the scope stack entry, and created the node to
2083 -- whose Declarations and Handled_Statement_Sequence fields are to be
2084 -- set. On return these fields are filled in (except in the case of a
2085 -- task body, where the handled statement sequence is optional, and may
2086 -- thus be Empty), and the scan is positioned past the End sequence.
2088 -- If the BEGIN is missing, then the parent node is used to help construct
2089 -- an appropriate missing BEGIN message. Possibilities for the parent are:
2091 -- N_Block_Statement declare block
2092 -- N_Entry_Body entry body
2093 -- N_Package_Body package body (begin part optional)
2094 -- N_Subprogram_Body procedure or function body
2095 -- N_Task_Body task body
2097 -- Note: in the case of a block statement, there is definitely a DECLARE
2098 -- present (because a Begin statement without a DECLARE is handled by the
2099 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
2101 -- Error recovery: cannot raise Error_Resync
2103 procedure Parse_Decls_Begin_End
(Parent
: Node_Id
) is
2104 Body_Decl
: Node_Id
;
2106 Parent_Nkind
: Node_Kind
;
2107 Spec_Node
: Node_Id
;
2110 procedure Missing_Begin
(Msg
: String);
2111 -- Called to post a missing begin message. In the normal case this is
2112 -- posted at the start of the current token. A special case arises when
2113 -- P_Declarative_Items has previously found a missing begin, in which
2114 -- case we replace the original error message.
2116 procedure Set_Null_HSS
(Parent
: Node_Id
);
2117 -- Construct an empty handled statement sequence and install in Parent
2118 -- Leaves HSS set to reference the newly constructed statement sequence.
2124 procedure Missing_Begin
(Msg
: String) is
2126 if Missing_Begin_Msg
= No_Error_Msg
then
2129 Change_Error_Text
(Missing_Begin_Msg
, Msg
);
2131 -- Purge any messages issued after than, since a missing begin
2132 -- can cause a lot of havoc, and it is better not to dump these
2133 -- cascaded messages on the user.
2135 Purge_Messages
(Get_Location
(Missing_Begin_Msg
), Prev_Token_Ptr
);
2143 procedure Set_Null_HSS
(Parent
: Node_Id
) is
2148 Make_Null_Statement
(Token_Ptr
);
2149 Set_Comes_From_Source
(Null_Stm
, False);
2152 Make_Handled_Sequence_Of_Statements
(Token_Ptr
,
2153 Statements
=> New_List
(Null_Stm
));
2154 Set_Comes_From_Source
(HSS
, False);
2156 Set_Handled_Statement_Sequence
(Parent
, HSS
);
2159 -- Start of processing for Parse_Decls_Begin_End
2162 Decls
:= P_Declarative_Part
;
2164 if Ada_Version
= Ada_83
then
2165 Check_Later_Vs_Basic_Declarations
(Decls
, During_Parsing
=> True);
2168 -- Here is where we deal with the case of IS used instead of semicolon.
2169 -- Specifically, if the last declaration in the declarative part is a
2170 -- subprogram body still marked as having a bad IS, then this is where
2171 -- we decide that the IS should really have been a semicolon and that
2172 -- the body should have been a declaration. Note that if the bad IS
2173 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2174 -- then the Bad_Is_Detected flag would have been reset by now.
2176 Body_Decl
:= Last
(Decls
);
2178 if Present
(Body_Decl
)
2179 and then Nkind
(Body_Decl
) = N_Subprogram_Body
2180 and then Bad_Is_Detected
(Body_Decl
)
2182 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2183 -- What we have now is a subprogram body with attached declarations
2184 -- and a possible statement sequence.
2186 -- First step is to take the declarations that were part of the bogus
2187 -- subprogram body and append them to the outer declaration chain.
2188 -- In other words we append them past the body (which we will later
2189 -- convert into a declaration).
2191 Append_List
(Declarations
(Body_Decl
), Decls
);
2193 -- Now take the handled statement sequence of the bogus body and
2194 -- set it as the statement sequence for the outer construct. Note
2195 -- that it may be empty (we specially allowed a missing BEGIN for
2196 -- a subprogram body marked as having a bad IS -- see below).
2198 Set_Handled_Statement_Sequence
(Parent
,
2199 Handled_Statement_Sequence
(Body_Decl
));
2201 -- Next step is to convert the old body node to a declaration node
2203 Spec_Node
:= Specification
(Body_Decl
);
2204 Change_Node
(Body_Decl
, N_Subprogram_Declaration
);
2205 Set_Specification
(Body_Decl
, Spec_Node
);
2207 -- Final step is to put the declarations for the parent where
2208 -- they belong, and then fall through the IF to scan out the
2211 Set_Declarations
(Parent
, Decls
);
2213 -- This is the normal case (i.e. any case except the bad IS case)
2214 -- If we have a BEGIN, then scan out the sequence of statements, and
2215 -- also reset the expected column for the END to match the BEGIN.
2218 Set_Declarations
(Parent
, Decls
);
2220 if Token
= Tok_Begin
then
2222 Style
.Check_Indentation
;
2225 Error_Msg_Col
:= Scopes
(Scope
.Last
).Ecol
;
2228 and then Token_Is_At_Start_Of_Line
2229 and then Start_Column
/= Error_Msg_Col
2231 Error_Msg_SC
("(style) BEGIN in wrong column, should be@?l?");
2234 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
2237 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
2239 Set_Handled_Statement_Sequence
(Parent
,
2240 P_Handled_Sequence_Of_Statements
);
2245 Parent_Nkind
:= Nkind
(Parent
);
2247 -- A special check for the missing IS case. If we have a
2248 -- subprogram body that was marked as having a suspicious
2249 -- IS, and the current token is END, then we simply confirm
2250 -- the suspicion, and do not require a BEGIN to be present
2252 if Parent_Nkind
= N_Subprogram_Body
2253 and then Token
= Tok_End
2254 and then Scopes
(Scope
.Last
).Etyp
= E_Suspicious_Is
2256 Scopes
(Scope
.Last
).Etyp
:= E_Bad_Is
;
2258 -- Otherwise BEGIN is not required for a package body, so we
2259 -- don't mind if it is missing, but we do construct a dummy
2260 -- one (so that we have somewhere to set End_Label).
2262 -- However if we have something other than a BEGIN which
2263 -- looks like it might be statements, then we signal a missing
2264 -- BEGIN for these cases as well. We define "something which
2265 -- looks like it might be statements" as a token other than
2266 -- END, EOF, or a token which starts declarations.
2268 elsif Parent_Nkind
= N_Package_Body
2269 and then Token
in Tok_End | Tok_EOF | Token_Class_Declk
2271 Set_Null_HSS
(Parent
);
2273 -- These are cases in which a BEGIN is required and not present
2276 Set_Null_HSS
(Parent
);
2278 -- Prepare to issue error message
2280 Error_Msg_Sloc
:= Scopes
(Scope
.Last
).Sloc
;
2281 Error_Msg_Node_1
:= Scopes
(Scope
.Last
).Labl
;
2283 -- Now issue appropriate message
2285 if Parent_Nkind
= N_Block_Statement
then
2286 Missing_Begin
("missing BEGIN for DECLARE#!");
2288 elsif Parent_Nkind
= N_Entry_Body
then
2289 Missing_Begin
("missing BEGIN for ENTRY#!");
2291 elsif Parent_Nkind
= N_Subprogram_Body
then
2292 if Nkind
(Specification
(Parent
))
2293 = N_Function_Specification
2295 Missing_Begin
("missing BEGIN for function&#!");
2297 Missing_Begin
("missing BEGIN for procedure&#!");
2300 -- The case for package body arises only when
2301 -- we have possible statement junk present.
2303 elsif Parent_Nkind
= N_Package_Body
then
2304 Missing_Begin
("missing BEGIN for package body&#!");
2307 pragma Assert
(Parent_Nkind
= N_Task_Body
);
2308 Missing_Begin
("missing BEGIN for task body&#!");
2311 -- Here we pick up the statements after the BEGIN that
2312 -- should have been present but was not. We don't insist
2313 -- on statements being present if P_Declarative_Part had
2314 -- already found a missing BEGIN, since it might have
2315 -- swallowed a lone statement into the declarative part.
2317 if Missing_Begin_Msg
/= No_Error_Msg
2318 and then Token
= Tok_End
2322 Set_Handled_Statement_Sequence
(Parent
,
2323 P_Handled_Sequence_Of_Statements
);
2329 -- Here with declarations and handled statement sequence scanned
2331 if Present
(Handled_Statement_Sequence
(Parent
)) then
2332 End_Statements
(Handled_Statement_Sequence
(Parent
));
2337 -- We know that End_Statements removed an entry from the scope stack
2338 -- (because it is required to do so under all circumstances). We can
2339 -- therefore reference the entry it removed one past the stack top.
2340 -- What we are interested in is whether it was a case of a bad IS.
2341 -- We can't call Scopes here.
2343 if Scope
.Table
(Scope
.Last
+ 1).Etyp
= E_Bad_Is
then
2344 Error_Msg
-- CODEFIX
2345 ("|IS should be "";""", Scope
.Table
(Scope
.Last
+ 1).S_Is
);
2346 Set_Bad_Is_Detected
(Parent
, True);
2349 end Parse_Decls_Begin_End
;
2351 -------------------------
2352 -- Set_Loop_Block_Name --
2353 -------------------------
2355 function Set_Loop_Block_Name
(L
: Character) return Name_Id
is
2357 Name_Buffer
(1) := L
;
2358 Name_Buffer
(2) := '_';
2360 Loop_Block_Count
:= Loop_Block_Count
+ 1;
2361 Add_Nat_To_Name_Buffer
(Loop_Block_Count
);
2363 end Set_Loop_Block_Name
;
2369 procedure Then_Scan
is
2373 while Token
= Tok_Then
loop
2374 Error_Msg_SC
-- CODEFIX
2379 if Token
in Tok_And | Tok_Or
then
2380 Error_Msg_SC
("unexpected logical operator");
2381 Scan
; -- past logical operator
2383 if (Prev_Token
= Tok_And
and then Token
= Tok_Then
)
2385 (Prev_Token
= Tok_Or
and then Token
= Tok_Else
)
2390 Discard_Junk_Node
(P_Expression
);
2393 if Token
= Tok_Then
then