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_Exit_Statement return Node_Id;
38 function P_Goto_Statement return Node_Id;
39 function P_If_Statement return Node_Id;
40 function P_Label return Node_Id;
41 function P_Null_Statement return Node_Id;
43 function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
44 -- Parse assignment statement. On entry, the caller has scanned the left
45 -- hand side (passed in as Lhs), and the colon-equal (or some symbol
46 -- taken to be an error equivalent such as equal).
48 function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id;
49 -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is
50 -- the N_Identifier node for the label on the block. If Block_Name is
51 -- Empty on entry (the default), then the block statement is unlabeled.
53 function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id;
54 -- Parse declare block. If Block_Name is non-Empty on entry, it is
55 -- the N_Identifier node for the label on the block. If Block_Name is
56 -- Empty on entry (the default), then the block statement is unlabeled.
58 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
59 -- Parse for statement. If Loop_Name is non-Empty on entry, it is
60 -- the N_Identifier node for the label on the loop. If Loop_Name is
61 -- Empty on entry (the default), then the for statement is unlabeled.
63 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
64 -- Parse loop statement. If Loop_Name is non-Empty on entry, it is
65 -- the N_Identifier node for the label on the loop. If Loop_Name is
66 -- Empty on entry (the default), then the loop statement is unlabeled.
68 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
69 -- Parse while statement. If Loop_Name is non-Empty on entry, it is
70 -- the N_Identifier node for the label on the loop. If Loop_Name is
71 -- Empty on entry (the default), then the while statement is unlabeled.
73 function Set_Loop_Block_Name (L : Character) return Name_Id;
74 -- Given a letter 'L' for a loop or 'B' for a block, returns a name
75 -- of the form L_nn or B_nn where nn is a serial number obtained by
76 -- incrementing the variable Loop_Block_Count.
79 -- Scan past THEN token, testing for illegal junk after it
81 ---------------------------------
82 -- 5.1 Sequence of Statements --
83 ---------------------------------
85 -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} {LABEL}
86 -- Note: the final label is an Ada 2012 addition.
89 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
91 -- SIMPLE_STATEMENT ::= NULL_STATEMENT
92 -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT
93 -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT
94 -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT
95 -- | REQUEUE_STATEMENT | DELAY_STATEMENT
96 -- | ABORT_STATEMENT | RAISE_STATEMENT
99 -- COMPOUND_STATEMENT ::=
100 -- IF_STATEMENT | CASE_STATEMENT
101 -- | LOOP_STATEMENT | BLOCK_STATEMENT
102 -- | ACCEPT_STATEMENT | SELECT_STATEMENT
104 -- This procedure scans a sequence of statements. The caller sets SS_Flags
105 -- to indicate acceptable termination conditions for the sequence:
107 -- SS_Flags.Eftm Terminate on ELSIF
108 -- SS_Flags.Eltm Terminate on ELSE
109 -- SS_Flags.Extm Terminate on EXCEPTION
110 -- SS_Flags.Ortm Terminate on OR
111 -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return)
112 -- SS_Flags.Whtm Terminate on WHEN
113 -- SS_Flags.Unco Unconditional terminate after scanning one statement
115 -- In addition, the scan is always terminated by encountering END or the
116 -- end of file (EOF) condition. If one of the six above terminators is
117 -- encountered with the corresponding SS_Flags flag not set, then the
118 -- action taken is as follows:
120 -- If the keyword occurs to the left of the expected column of the end
121 -- for the current sequence (as recorded in the current end context),
122 -- then it is assumed to belong to an outer context, and is considered
123 -- to terminate the sequence of statements.
125 -- If the keyword occurs to the right of, or in the expected column of
126 -- the end for the current sequence, then an error message is output,
127 -- the keyword together with its associated context is skipped, and
128 -- the statement scan continues until another terminator is found.
130 -- Note that the first action means that control can return to the caller
131 -- with Token set to a terminator other than one of those specified by the
132 -- SS parameter. The caller should treat such a case as equivalent to END.
134 -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at
135 -- least one real statement (other than a pragma) is required in the
136 -- statement sequence. During the processing of the sequence, this
137 -- flag is manipulated to indicate the current status of the requirement
138 -- for a statement. For example, it is turned off by the occurrence of a
139 -- statement, and back on by a label (which requires a following statement)
141 -- Error recovery: cannot raise Error_Resync. If an error occurs during
142 -- parsing a statement, then the scan pointer is advanced past the next
143 -- semicolon and the parse continues.
145 function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is
147 Statement_Required : Boolean;
148 -- This flag indicates if a subsequent statement (other than a pragma)
149 -- is required. It is initialized from the Sreq flag, and modified as
150 -- statements are scanned (a statement turns it off, and a label turns
151 -- it back on again since a statement must follow a label).
152 -- Note : this final requirement is lifted in Ada 2012.
154 Statement_Seen : Boolean;
155 -- In Ada 2012, a label can end a sequence of statements, but the
156 -- sequence cannot contain only labels. This flag is set whenever a
157 -- label is encountered, to enforce this rule at the end of a sequence.
159 Declaration_Found : Boolean := False;
160 -- This flag is set True if a declaration is encountered, so that the
161 -- error message about declarations in the statement part is only
162 -- given once for a given sequence of statements.
164 Scan_State_Label : Saved_Scan_State;
165 Scan_State : Saved_Scan_State;
167 Statement_List : List_Id;
168 Block_Label : Name_Id;
172 procedure Junk_Declaration;
173 -- Procedure called to handle error of declaration encountered in
174 -- statement sequence.
176 procedure Test_Statement_Required;
177 -- Flag error if Statement_Required flag set
179 ----------------------
180 -- Junk_Declaration --
181 ----------------------
183 procedure Junk_Declaration is
185 if (not Declaration_Found) or All_Errors_Mode then
186 Error_Msg_SC -- CODEFIX
187 ("declarations must come before BEGIN");
188 Declaration_Found := True;
191 Skip_Declaration (Statement_List);
192 end Junk_Declaration;
194 -----------------------------
195 -- Test_Statement_Required --
196 -----------------------------
198 procedure Test_Statement_Required is
199 function All_Pragmas return Boolean;
200 -- Return True if statement list is all pragmas
206 function All_Pragmas return Boolean is
209 S := First (Statement_List);
210 while Present (S) loop
211 if Nkind (S) /= N_Pragma then
221 -- Start of processing for Test_Statement_Required
224 if Statement_Required then
226 -- Check no statement required after label in Ada 2012, and that
227 -- it is OK to have nothing but pragmas in a statement sequence.
229 if Ada_Version >= Ada_2012
230 and then not Is_Empty_List (Statement_List)
232 ((Nkind (Last (Statement_List)) = N_Label
233 and then Statement_Seen)
237 Null_Stm : constant Node_Id :=
238 Make_Null_Statement (Token_Ptr);
240 Set_Comes_From_Source (Null_Stm, False);
241 Append_To (Statement_List, Null_Stm);
244 -- If not Ada 2012, or not special case above, give error message
247 Error_Msg_BC -- CODEFIX
248 ("statement expected");
251 end Test_Statement_Required;
253 -- Start of processing for P_Sequence_Of_Statements
256 Statement_List := New_List;
257 Statement_Required := SS_Flags.Sreq;
258 Statement_Seen := False;
261 Ignore (Tok_Semicolon);
265 Style.Check_Indentation;
268 -- Deal with reserved identifier (in assignment or call)
270 if Is_Reserved_Identifier then
271 Save_Scan_State (Scan_State); -- at possible bad identifier
272 Scan; -- and scan past it
274 -- We have an reserved word which is spelled in identifier
275 -- style, so the question is whether it really is intended
276 -- to be an identifier.
279 -- If followed by a semicolon, then it is an identifier,
280 -- with the exception of the cases tested for below.
282 (Token = Tok_Semicolon
283 and then Prev_Token /= Tok_Return
284 and then Prev_Token /= Tok_Null
285 and then Prev_Token /= Tok_Raise
286 and then Prev_Token /= Tok_End
287 and then Prev_Token /= Tok_Exit)
289 -- If followed by colon, colon-equal, or dot, then we
290 -- definitely have an identifier (could not be reserved)
292 or else Token = Tok_Colon
293 or else Token = Tok_Colon_Equal
294 or else Token = Tok_Dot
296 -- Left paren means we have an identifier except for those
297 -- reserved words that can legitimately be followed by a
301 (Token = Tok_Left_Paren
302 and then Prev_Token /= Tok_Case
303 and then Prev_Token /= Tok_Delay
304 and then Prev_Token /= Tok_If
305 and then Prev_Token /= Tok_Elsif
306 and then Prev_Token /= Tok_Return
307 and then Prev_Token /= Tok_When
308 and then Prev_Token /= Tok_While
309 and then Prev_Token /= Tok_Separate)
311 -- Here we have an apparent reserved identifier and the
312 -- token past it is appropriate to this usage (and would
313 -- be a definite error if this is not an identifier). What
314 -- we do is to use P_Identifier to fix up the identifier,
315 -- and then fall into the normal processing.
317 Restore_Scan_State (Scan_State); -- back to the ID
318 Scan_Reserved_Identifier (Force_Msg => False);
320 -- Not a reserved identifier after all (or at least we can't
321 -- be sure that it is), so reset the scan and continue.
324 Restore_Scan_State (Scan_State); -- back to the reserved word
328 -- Now look to see what kind of statement we have
332 -- Case of end or EOF
334 when Tok_End | Tok_EOF =>
336 -- These tokens always terminate the statement sequence
338 Test_Statement_Required;
345 -- Terminate if Eftm set or if the ELSIF is to the left
346 -- of the expected column of the end for this sequence
349 or else Start_Column < Scope.Table (Scope.Last).Ecol
351 Test_Statement_Required;
354 -- Otherwise complain and skip past ELSIF Condition then
357 Error_Msg_SC ("ELSIF not allowed here");
359 Discard_Junk_Node (P_Expression_No_Right_Paren);
361 Statement_Required := False;
368 -- Terminate if Eltm set or if the else is to the left
369 -- of the expected column of the end for this sequence
372 or else Start_Column < Scope.Table (Scope.Last).Ecol
374 Test_Statement_Required;
377 -- Otherwise complain and skip past else
380 Error_Msg_SC ("ELSE not allowed here");
382 Statement_Required := False;
387 when Tok_Exception =>
388 Test_Statement_Required;
390 -- If Extm not set and the exception is not to the left of
391 -- the expected column of the end for this sequence, then we
392 -- assume it belongs to the current sequence, even though it
395 if not SS_Flags.Extm and then
396 Start_Column >= Scope.Table (Scope.Last).Ecol
399 Error_Msg_SC ("exception handler not permitted here");
400 Scan; -- past EXCEPTION
401 Discard_Junk_List (Parse_Exception_Handlers);
404 -- Always return, in the case where we scanned out handlers
405 -- that we did not expect, Parse_Exception_Handlers returned
406 -- with Token being either end or EOF, so we are OK.
414 -- Terminate if Ortm set or if the or is to the left of the
415 -- expected column of the end for this sequence.
418 or else Start_Column < Scope.Table (Scope.Last).Ecol
420 Test_Statement_Required;
423 -- Otherwise complain and skip past or
426 Error_Msg_SC ("OR not allowed here");
428 Statement_Required := False;
431 -- Case of THEN (deal also with THEN ABORT)
434 Save_Scan_State (Scan_State); -- at THEN
437 -- Terminate if THEN ABORT allowed (ATC case)
439 exit when SS_Flags.Tatm and then Token = Tok_Abort;
441 -- Otherwise we treat THEN as some kind of mess where we did
442 -- not see the associated IF, but we pick up assuming it had
445 Restore_Scan_State (Scan_State); -- to THEN
446 Append_To (Statement_List, P_If_Statement);
447 Statement_Required := False;
449 -- Case of WHEN (error because we are not in a case)
451 when Tok_When | Tok_Others =>
453 -- Terminate if Whtm set or if the WHEN is to the left of
454 -- the expected column of the end for this sequence.
457 or else Start_Column < Scope.Table (Scope.Last).Ecol
459 Test_Statement_Required;
462 -- Otherwise complain and skip when Choice {| Choice} =>
465 Error_Msg_SC ("WHEN not allowed here");
467 Discard_Junk_List (P_Discrete_Choice_List);
469 Statement_Required := False;
472 -- Cases of statements starting with an identifier
474 when Tok_Identifier =>
477 -- Save scan pointers and line number in case block label
479 Id_Node := Token_Node;
480 Block_Label := Token_Name;
481 Save_Scan_State (Scan_State_Label); -- at possible label
484 -- Check for common case of assignment, since it occurs
485 -- frequently, and we want to process it efficiently.
487 if Token = Tok_Colon_Equal then
488 Scan; -- past the colon-equal
489 Append_To (Statement_List,
490 P_Assignment_Statement (Id_Node));
491 Statement_Required := False;
493 -- Check common case of procedure call, another case that
494 -- we want to speed up as much as possible.
496 elsif Token = Tok_Semicolon then
497 Append_To (Statement_List,
498 P_Statement_Name (Id_Node));
499 Scan; -- past semicolon
500 Statement_Required := False;
502 -- Check for case of "go to" in place of "goto"
504 elsif Token = Tok_Identifier
505 and then Block_Label = Name_Go
506 and then Token_Name = Name_To
508 Error_Msg_SP -- CODEFIX
509 ("goto is one word");
510 Append_To (Statement_List, P_Goto_Statement);
511 Statement_Required := False;
513 -- Check common case of = used instead of :=, just so we
514 -- give a better error message for this special misuse.
516 elsif Token = Tok_Equal then
517 T_Colon_Equal; -- give := expected message
518 Append_To (Statement_List,
519 P_Assignment_Statement (Id_Node));
520 Statement_Required := False;
522 -- Check case of loop label or block label
524 elsif Token = Tok_Colon
525 or else (Token in Token_Class_Labeled_Stmt
526 and then not Token_Is_At_Start_Of_Line)
528 T_Colon; -- past colon (if there, or msg for missing one)
530 -- Test for more than one label
533 exit when Token /= Tok_Identifier;
534 Save_Scan_State (Scan_State); -- at second Id
537 if Token = Tok_Colon then
539 ("only one label allowed on block or loop");
540 Scan; -- past colon on extra label
542 -- Use the second label as the "real" label
544 Scan_State_Label := Scan_State;
546 -- We will set Error_name as the Block_Label since
547 -- we really don't know which of the labels might
548 -- be used at the end of the loop or block!
550 Block_Label := Error_Name;
552 -- If Id with no colon, then backup to point to the
553 -- Id and we will issue the message below when we try
554 -- to scan out the statement as some other form.
557 Restore_Scan_State (Scan_State); -- to second Id
562 -- Loop_Statement (labeled Loop_Statement)
564 if Token = Tok_Loop then
565 Append_To (Statement_List,
566 P_Loop_Statement (Id_Node));
568 -- While statement (labeled loop statement with WHILE)
570 elsif Token = Tok_While then
571 Append_To (Statement_List,
572 P_While_Statement (Id_Node));
574 -- Declare statement (labeled block statement with
577 elsif Token = Tok_Declare then
578 Append_To (Statement_List,
579 P_Declare_Statement (Id_Node));
581 -- Begin statement (labeled block statement with no
584 elsif Token = Tok_Begin then
585 Append_To (Statement_List,
586 P_Begin_Statement (Id_Node));
588 -- For statement (labeled loop statement with FOR)
590 elsif Token = Tok_For then
591 Append_To (Statement_List,
592 P_For_Statement (Id_Node));
594 -- Improper statement follows label. If we have an
595 -- expression token, then assume the colon was part
596 -- of a misplaced declaration.
598 elsif Token not in Token_Class_Eterm then
599 Restore_Scan_State (Scan_State_Label);
602 -- Otherwise complain we have inappropriate statement
606 ("loop or block statement must follow label");
609 Statement_Required := False;
611 -- Here we have an identifier followed by something
612 -- other than a colon, semicolon or assignment symbol.
613 -- The only valid possibility is a name extension symbol
615 elsif Token in Token_Class_Namext then
616 Restore_Scan_State (Scan_State_Label); -- to Id
619 -- Skip junk right parens in this context
621 Ignore (Tok_Right_Paren);
623 -- Check context following call
625 if Token = Tok_Colon_Equal then
626 Scan; -- past colon equal
627 Append_To (Statement_List,
628 P_Assignment_Statement (Name_Node));
629 Statement_Required := False;
631 -- Check common case of = used instead of :=
633 elsif Token = Tok_Equal then
634 T_Colon_Equal; -- give := expected message
635 Append_To (Statement_List,
636 P_Assignment_Statement (Name_Node));
637 Statement_Required := False;
639 -- Check apostrophe cases
641 elsif Token = Tok_Apostrophe then
642 Append_To (Statement_List,
643 P_Code_Statement (Name_Node));
644 Statement_Required := False;
646 -- The only other valid item after a name is ; which
647 -- means that the item we just scanned was a call.
649 elsif Token = Tok_Semicolon then
650 Append_To (Statement_List,
651 P_Statement_Name (Name_Node));
652 Scan; -- past semicolon
653 Statement_Required := False;
655 -- A slash following an identifier or a selected
656 -- component in this situation is most likely a period
657 -- (see location of keys on keyboard).
659 elsif Token = Tok_Slash
660 and then (Nkind (Name_Node) = N_Identifier
662 Nkind (Name_Node) = N_Selected_Component)
664 Error_Msg_SC -- CODEFIX
665 ("""/"" should be "".""");
666 Statement_Required := False;
669 -- Else we have a missing semicolon
673 Statement_Required := False;
676 -- If junk after identifier, check if identifier is an
677 -- instance of an incorrectly spelled keyword. If so, we
678 -- do nothing. The Bad_Spelling_Of will have reset Token
679 -- to the appropriate keyword, so the next time round the
680 -- loop we will process the modified token. Note that we
681 -- check for ELSIF before ELSE here. That's not accidental.
682 -- We don't want to identify a misspelling of ELSE as
683 -- ELSIF, and in particular we do not want to treat ELSEIF
687 Restore_Scan_State (Scan_State_Label); -- to identifier
689 if Bad_Spelling_Of (Tok_Abort)
690 or else Bad_Spelling_Of (Tok_Accept)
691 or else Bad_Spelling_Of (Tok_Case)
692 or else Bad_Spelling_Of (Tok_Declare)
693 or else Bad_Spelling_Of (Tok_Delay)
694 or else Bad_Spelling_Of (Tok_Elsif)
695 or else Bad_Spelling_Of (Tok_Else)
696 or else Bad_Spelling_Of (Tok_End)
697 or else Bad_Spelling_Of (Tok_Exception)
698 or else Bad_Spelling_Of (Tok_Exit)
699 or else Bad_Spelling_Of (Tok_For)
700 or else Bad_Spelling_Of (Tok_Goto)
701 or else Bad_Spelling_Of (Tok_If)
702 or else Bad_Spelling_Of (Tok_Loop)
703 or else Bad_Spelling_Of (Tok_Or)
704 or else Bad_Spelling_Of (Tok_Pragma)
705 or else Bad_Spelling_Of (Tok_Raise)
706 or else Bad_Spelling_Of (Tok_Requeue)
707 or else Bad_Spelling_Of (Tok_Return)
708 or else Bad_Spelling_Of (Tok_Select)
709 or else Bad_Spelling_Of (Tok_When)
710 or else Bad_Spelling_Of (Tok_While)
714 -- If not a bad spelling, then we really have junk
717 Scan; -- past identifier again
719 -- If next token is first token on line, then we
720 -- consider that we were missing a semicolon after
721 -- the identifier, and process it as a procedure
722 -- call with no parameters.
724 if Token_Is_At_Start_Of_Line then
725 Append_To (Statement_List,
726 P_Statement_Name (Id_Node));
727 T_Semicolon; -- to give error message
728 Statement_Required := False;
730 -- Otherwise we give a missing := message and
731 -- simply abandon the junk that is there now.
734 T_Colon_Equal; -- give := expected message
741 -- Statement starting with operator symbol. This could be
742 -- a call, a name starting an assignment, or a qualified
745 when Tok_Operator_Symbol =>
749 -- An attempt at a range attribute or a qualified expression
750 -- must be illegal here (a code statement cannot possibly
751 -- allow qualification by a function name).
753 if Token = Tok_Apostrophe then
754 Error_Msg_SC ("apostrophe illegal here");
758 -- Scan possible assignment if we have a name
760 if Expr_Form = EF_Name
761 and then Token = Tok_Colon_Equal
763 Scan; -- past colon equal
764 Append_To (Statement_List,
765 P_Assignment_Statement (Name_Node));
767 Append_To (Statement_List,
768 P_Statement_Name (Name_Node));
772 Statement_Required := False;
774 -- Label starting with << which must precede real statement
775 -- Note: in Ada 2012, the label may end the sequence.
777 when Tok_Less_Less =>
778 if Present (Last (Statement_List))
779 and then Nkind (Last (Statement_List)) /= N_Label
781 Statement_Seen := True;
784 Append_To (Statement_List, P_Label);
785 Statement_Required := True;
787 -- Pragma appearing as a statement in a statement sequence
791 Append_To (Statement_List, P_Pragma);
797 Append_To (Statement_List, P_Abort_Statement);
798 Statement_Required := False;
804 Append_To (Statement_List, P_Accept_Statement);
805 Statement_Required := False;
807 -- Begin_Statement (Block_Statement with no declare, no label)
811 Append_To (Statement_List, P_Begin_Statement);
812 Statement_Required := False;
818 Append_To (Statement_List, P_Case_Statement);
819 Statement_Required := False;
821 -- Block_Statement with DECLARE and no label
825 Append_To (Statement_List, P_Declare_Statement);
826 Statement_Required := False;
832 Append_To (Statement_List, P_Delay_Statement);
833 Statement_Required := False;
839 Append_To (Statement_List, P_Exit_Statement);
840 Statement_Required := False;
842 -- Loop_Statement with FOR and no label
846 Append_To (Statement_List, P_For_Statement);
847 Statement_Required := False;
853 Append_To (Statement_List, P_Goto_Statement);
854 Statement_Required := False;
860 Append_To (Statement_List, P_If_Statement);
861 Statement_Required := False;
867 Append_To (Statement_List, P_Loop_Statement);
868 Statement_Required := False;
874 Append_To (Statement_List, P_Null_Statement);
875 Statement_Required := False;
881 Append_To (Statement_List, P_Raise_Statement);
882 Statement_Required := False;
888 Append_To (Statement_List, P_Requeue_Statement);
889 Statement_Required := False;
895 Append_To (Statement_List, P_Return_Statement);
896 Statement_Required := False;
902 Append_To (Statement_List, P_Select_Statement);
903 Statement_Required := False;
905 -- While_Statement (Block_Statement with while and no loop)
909 Append_To (Statement_List, P_While_Statement);
910 Statement_Required := False;
912 -- Anything else is some kind of junk, signal an error message
913 -- and then raise Error_Resync, to merge with the normal
914 -- handling of a bad statement.
918 if Token in Token_Class_Declk then
922 Error_Msg_BC -- CODEFIX
923 ("statement expected");
928 -- On error resynchronization, skip past next semicolon, and, since
929 -- we are still in the statement loop, look for next statement. We
930 -- set Statement_Required False to avoid an unnecessary error message
931 -- complaining that no statement was found (i.e. we consider the
932 -- junk to satisfy the requirement for a statement being present).
936 Resync_Past_Semicolon_Or_To_Loop_Or_Then;
937 Statement_Required := False;
940 exit when SS_Flags.Unco;
944 return Statement_List;
946 end P_Sequence_Of_Statements;
952 -- Parsed by P_Sequence_Of_Statements (5.1), except for the case
953 -- of a statement of the form of a name, which is handled here. The
954 -- argument passed in is the tree for the name which has been scanned
955 -- The returned value is the corresponding statement form.
957 -- This routine is also used by Par.Prag for processing the procedure
958 -- call that appears as the second argument of a pragma Assert.
960 -- Error recovery: cannot raise Error_Resync
962 function P_Statement_Name (Name_Node : Node_Id) return Node_Id is
966 -- Case of Indexed component, which is a procedure call with arguments
968 if Nkind (Name_Node) = N_Indexed_Component then
970 Prefix_Node : constant Node_Id := Prefix (Name_Node);
971 Exprs_Node : constant List_Id := Expressions (Name_Node);
974 Change_Node (Name_Node, N_Procedure_Call_Statement);
975 Set_Name (Name_Node, Prefix_Node);
976 Set_Parameter_Associations (Name_Node, Exprs_Node);
980 -- Case of function call node, which is a really a procedure call
982 elsif Nkind (Name_Node) = N_Function_Call then
984 Fname_Node : constant Node_Id := Name (Name_Node);
985 Params_List : constant List_Id :=
986 Parameter_Associations (Name_Node);
989 Change_Node (Name_Node, N_Procedure_Call_Statement);
990 Set_Name (Name_Node, Fname_Node);
991 Set_Parameter_Associations (Name_Node, Params_List);
995 -- Case of call to attribute that denotes a procedure. Here we
996 -- just leave the attribute reference unchanged.
998 elsif Nkind (Name_Node) = N_Attribute_Reference
999 and then Is_Procedure_Attribute_Name (Attribute_Name (Name_Node))
1003 -- All other cases of names are parameterless procedure calls
1007 New_Node (N_Procedure_Call_Statement, Sloc (Name_Node));
1008 Set_Name (Stmt_Node, Name_Node);
1012 end P_Statement_Name;
1014 ---------------------------
1015 -- 5.1 Simple Statement --
1016 ---------------------------
1018 -- Parsed by P_Sequence_Of_Statements (5.1)
1020 -----------------------------
1021 -- 5.1 Compound Statement --
1022 -----------------------------
1024 -- Parsed by P_Sequence_Of_Statements (5.1)
1026 -------------------------
1027 -- 5.1 Null Statement --
1028 -------------------------
1030 -- NULL_STATEMENT ::= null;
1032 -- The caller has already checked that the current token is null
1034 -- Error recovery: cannot raise Error_Resync
1036 function P_Null_Statement return Node_Id is
1037 Null_Stmt_Node : Node_Id;
1040 Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr);
1043 return Null_Stmt_Node;
1044 end P_Null_Statement;
1050 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
1052 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
1054 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
1055 -- (not an OPERATOR_SYMBOL)
1057 -- The caller has already checked that the current token is <<
1059 -- Error recovery: can raise Error_Resync
1061 function P_Label return Node_Id is
1062 Label_Node : Node_Id;
1065 Label_Node := New_Node (N_Label, Token_Ptr);
1067 Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
1069 Append_Elmt (Label_Node, Label_List);
1073 -------------------------------
1074 -- 5.1 Statement Identifier --
1075 -------------------------------
1077 -- Statement label is parsed by P_Label (5.1)
1079 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1080 -- or P_While_Statement (5.5)
1082 -- Block label is parsed by P_Begin_Statement (5.6) or
1083 -- P_Declare_Statement (5.6)
1085 -------------------------------
1086 -- 5.2 Assignment Statement --
1087 -------------------------------
1089 -- ASSIGNMENT_STATEMENT ::=
1090 -- variable_NAME := EXPRESSION;
1092 -- Error recovery: can raise Error_Resync
1094 function P_Assignment_Statement (LHS : Node_Id) return Node_Id is
1095 Assign_Node : Node_Id;
1098 Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr);
1099 Set_Name (Assign_Node, LHS);
1100 Set_Expression (Assign_Node, P_Expression_No_Right_Paren);
1103 end P_Assignment_Statement;
1105 -----------------------
1106 -- 5.3 If Statement --
1107 -----------------------
1110 -- if CONDITION then
1111 -- SEQUENCE_OF_STATEMENTS
1112 -- {elsif CONDITION then
1113 -- SEQUENCE_OF_STATEMENTS}
1115 -- SEQUENCE_OF_STATEMENTS]
1118 -- The caller has checked that the initial token is IF (or in the error
1119 -- case of a mysterious THEN, the initial token may simply be THEN, in
1120 -- which case, no condition (or IF) was scanned).
1122 -- Error recovery: can raise Error_Resync
1124 function P_If_Statement return Node_Id is
1126 Elsif_Node : Node_Id;
1129 procedure Add_Elsif_Part;
1130 -- An internal procedure used to scan out a single ELSIF part. On entry
1131 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1132 -- scanned out and is in Prev_Token.
1134 procedure Check_If_Column;
1135 -- An internal procedure used to check that THEN, ELSE, or ELSIF
1136 -- appear in the right place if column checking is enabled (i.e. if
1137 -- they are the first token on the line, then they must appear in
1138 -- the same column as the opening IF).
1140 procedure Check_Then_Column;
1141 -- This procedure carries out the style checks for a THEN token
1142 -- Note that the caller has set Loc to the Source_Ptr value for
1143 -- the previous IF or ELSIF token. These checks apply only to a
1144 -- THEN at the start of a line.
1146 function Else_Should_Be_Elsif return Boolean;
1147 -- An internal routine used to do a special error recovery check when
1148 -- an ELSE is encountered. It determines if the ELSE should be treated
1149 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1150 -- is followed by a sequence of tokens, starting on the same line as
1151 -- the ELSE, which are not expression terminators, followed by a THEN.
1152 -- On entry, the ELSE has been scanned out.
1154 procedure Add_Elsif_Part is
1156 if No (Elsif_Parts (If_Node)) then
1157 Set_Elsif_Parts (If_Node, New_List);
1160 Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr);
1161 Loc := Prev_Token_Ptr;
1162 Set_Condition (Elsif_Node, P_Condition);
1166 (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1167 Append (Elsif_Node, Elsif_Parts (If_Node));
1170 procedure Check_If_Column is
1172 if RM_Column_Check and then Token_Is_At_Start_Of_Line
1173 and then Start_Column /= Scope.Table (Scope.Last).Ecol
1175 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
1176 Error_Msg_SC ("(style) this token should be@");
1178 end Check_If_Column;
1180 procedure Check_Then_Column is
1182 if Token_Is_At_Start_Of_Line and then Token = Tok_Then then
1186 Style.Check_Then (Loc);
1189 end Check_Then_Column;
1191 function Else_Should_Be_Elsif return Boolean is
1192 Scan_State : Saved_Scan_State;
1195 if Token_Is_At_Start_Of_Line then
1199 Save_Scan_State (Scan_State);
1202 if Token in Token_Class_Eterm then
1203 Restore_Scan_State (Scan_State);
1206 Scan; -- past non-expression terminating token
1208 if Token = Tok_Then then
1209 Restore_Scan_State (Scan_State);
1215 end Else_Should_Be_Elsif;
1217 -- Start of processing for P_If_Statement
1220 If_Node := New_Node (N_If_Statement, Token_Ptr);
1223 Scope.Table (Scope.Last).Etyp := E_If;
1224 Scope.Table (Scope.Last).Ecol := Start_Column;
1225 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1226 Scope.Table (Scope.Last).Labl := Error;
1227 Scope.Table (Scope.Last).Node := If_Node;
1229 if Token = Tok_If then
1232 Set_Condition (If_Node, P_Condition);
1234 -- Deal with misuse of IF expression => used instead
1235 -- of WHEN expression =>
1237 if Token = Tok_Arrow then
1238 Error_Msg_SC -- CODEFIX
1240 Scan; -- past the arrow
1241 Pop_Scope_Stack; -- remove unneeded entry
1248 Error_Msg_SC ("no IF for this THEN");
1249 Set_Condition (If_Node, Error);
1255 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1257 -- This loop scans out else and elsif parts
1260 if Token = Tok_Elsif then
1263 if Present (Else_Statements (If_Node)) then
1264 Error_Msg_SP ("ELSIF cannot appear after ELSE");
1270 elsif Token = Tok_Else then
1274 if Else_Should_Be_Elsif then
1275 Error_Msg_SP -- CODEFIX
1276 ("ELSE should be ELSIF");
1280 -- Here we have an else that really is an else
1282 if Present (Else_Statements (If_Node)) then
1283 Error_Msg_SP ("only one ELSE part allowed");
1285 (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
1286 Else_Statements (If_Node));
1289 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1293 -- If anything other than ELSE or ELSIF, exit the loop. The token
1294 -- had better be END (and in fact it had better be END IF), but
1295 -- we will let End_Statements take care of checking that.
1307 --------------------
1309 --------------------
1311 -- CONDITION ::= boolean_EXPRESSION
1313 function P_Condition return Node_Id is
1317 Cond := P_Expression_No_Right_Paren;
1319 -- It is never possible for := to follow a condition, so if we get
1320 -- a := we assume it is a mistyped equality. Note that we do not try
1321 -- to reconstruct the tree correctly in this case, but we do at least
1322 -- give an accurate error message.
1324 if Token = Tok_Colon_Equal then
1325 while Token = Tok_Colon_Equal loop
1326 Error_Msg_SC -- CODEFIX
1327 (""":="" should be ""=""");
1328 Scan; -- past junk :=
1329 Discard_Junk_Node (P_Expression_No_Right_Paren);
1334 -- Otherwise check for redundant parens
1338 and then Paren_Count (Cond) > 0
1340 Style.Check_Xtra_Parens (First_Sloc (Cond));
1343 -- And return the result
1349 -------------------------
1350 -- 5.4 Case Statement --
1351 -------------------------
1353 -- CASE_STATEMENT ::=
1354 -- case EXPRESSION is
1355 -- CASE_STATEMENT_ALTERNATIVE
1356 -- {CASE_STATEMENT_ALTERNATIVE}
1359 -- The caller has checked that the first token is CASE
1361 -- Can raise Error_Resync
1363 function P_Case_Statement return Node_Id is
1364 Case_Node : Node_Id;
1365 Alternatives_List : List_Id;
1366 First_When_Loc : Source_Ptr;
1369 Case_Node := New_Node (N_Case_Statement, Token_Ptr);
1372 Scope.Table (Scope.Last).Etyp := E_Case;
1373 Scope.Table (Scope.Last).Ecol := Start_Column;
1374 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1375 Scope.Table (Scope.Last).Labl := Error;
1376 Scope.Table (Scope.Last).Node := Case_Node;
1379 Set_Expression (Case_Node, P_Expression_No_Right_Paren);
1382 -- Prepare to parse case statement alternatives
1384 Alternatives_List := New_List;
1385 P_Pragmas_Opt (Alternatives_List);
1386 First_When_Loc := Token_Ptr;
1388 -- Loop through case statement alternatives
1391 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1392 -- that it is a semantic check to ensure the proper use of OTHERS
1394 if Token = Tok_When or else Token = Tok_Others then
1395 Append (P_Case_Statement_Alternative, Alternatives_List);
1397 -- If we have an END, then probably we are at the end of the case
1398 -- but we only exit if Check_End thinks the END was reasonable.
1400 elsif Token = Tok_End then
1401 exit when Check_End;
1403 -- Here if token is other than WHEN, OTHERS or END. We definitely
1404 -- have an error, but the question is whether or not to get out of
1405 -- the case statement. We don't want to get out early, or we will
1406 -- get a slew of junk error messages for subsequent when tokens.
1408 -- If the token is not at the start of the line, or if it is indented
1409 -- with respect to the current case statement, then the best guess is
1410 -- that we are still supposed to be inside the case statement. We
1411 -- complain about the missing WHEN, and discard the junk statements.
1413 elsif not Token_Is_At_Start_Of_Line
1414 or else Start_Column > Scope.Table (Scope.Last).Ecol
1416 Error_Msg_BC ("WHEN (case statement alternative) expected");
1418 -- Here is a possibility for infinite looping if we don't make
1419 -- progress. So try to process statements, otherwise exit
1422 Error_Ptr : constant Source_Ptr := Scan_Ptr;
1424 Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm));
1425 exit when Scan_Ptr = Error_Ptr and then Check_End;
1428 -- Here we have a junk token at the start of the line and it is
1429 -- not indented. If Check_End thinks there is a missing END, then
1430 -- we will get out of the case, otherwise we keep going.
1433 exit when Check_End;
1437 -- Make sure we have at least one alternative
1439 if No (First_Non_Pragma (Alternatives_List)) then
1441 ("WHEN expected, must have at least one alternative in case",
1446 Set_Alternatives (Case_Node, Alternatives_List);
1449 end P_Case_Statement;
1451 -------------------------------------
1452 -- 5.4 Case Statement Alternative --
1453 -------------------------------------
1455 -- CASE_STATEMENT_ALTERNATIVE ::=
1456 -- when DISCRETE_CHOICE_LIST =>
1457 -- SEQUENCE_OF_STATEMENTS
1459 -- The caller has checked that the initial token is WHEN or OTHERS
1460 -- Error recovery: can raise Error_Resync
1462 function P_Case_Statement_Alternative return Node_Id is
1463 Case_Alt_Node : Node_Id;
1467 Style.Check_Indentation;
1470 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
1471 T_When; -- past WHEN (or give error in OTHERS case)
1472 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
1474 Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
1475 return Case_Alt_Node;
1476 end P_Case_Statement_Alternative;
1478 -------------------------
1479 -- 5.5 Loop Statement --
1480 -------------------------
1482 -- LOOP_STATEMENT ::=
1483 -- [LOOP_STATEMENT_IDENTIFIER:]
1484 -- [ITERATION_SCHEME] loop
1485 -- SEQUENCE_OF_STATEMENTS
1486 -- end loop [loop_IDENTIFIER];
1488 -- ITERATION_SCHEME ::=
1490 -- | for LOOP_PARAMETER_SPECIFICATION
1492 -- The parsing of loop statements is handled by one of three functions
1493 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1494 -- on the initial keyword in the construct (excluding the identifier)
1498 -- This function parses the case where no iteration scheme is present
1500 -- The caller has checked that the initial token is LOOP. The parameter
1501 -- is the node identifiers for the loop label if any (or is set to Empty
1502 -- if there is no loop label).
1504 -- Error recovery : cannot raise Error_Resync
1506 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1507 Loop_Node : Node_Id;
1508 Created_Name : Node_Id;
1512 Scope.Table (Scope.Last).Labl := Loop_Name;
1513 Scope.Table (Scope.Last).Ecol := Start_Column;
1514 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1515 Scope.Table (Scope.Last).Etyp := E_Loop;
1517 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1520 if No (Loop_Name) then
1522 Make_Identifier (Sloc (Loop_Node),
1523 Chars => Set_Loop_Block_Name ('L'));
1524 Set_Comes_From_Source (Created_Name, False);
1525 Set_Has_Created_Identifier (Loop_Node, True);
1526 Set_Identifier (Loop_Node, Created_Name);
1527 Scope.Table (Scope.Last).Labl := Created_Name;
1529 Set_Identifier (Loop_Node, Loop_Name);
1532 Append_Elmt (Loop_Node, Label_List);
1533 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1534 End_Statements (Loop_Node);
1536 end P_Loop_Statement;
1540 -- This function parses a loop statement with a FOR iteration scheme
1542 -- The caller has checked that the initial token is FOR. The parameter
1543 -- is the node identifier for the block label if any (or is set to Empty
1544 -- if there is no block label).
1546 -- Note: the caller fills in the Identifier field if a label was present
1548 -- Error recovery: can raise Error_Resync
1550 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1551 Loop_Node : Node_Id;
1552 Iter_Scheme_Node : Node_Id;
1553 Loop_For_Flag : Boolean;
1554 Created_Name : Node_Id;
1558 Scope.Table (Scope.Last).Labl := Loop_Name;
1559 Scope.Table (Scope.Last).Ecol := Start_Column;
1560 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1561 Scope.Table (Scope.Last).Etyp := E_Loop;
1563 Loop_For_Flag := (Prev_Token = Tok_Loop);
1565 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1566 Set_Loop_Parameter_Specification
1567 (Iter_Scheme_Node, P_Loop_Parameter_Specification);
1569 -- The following is a special test so that a miswritten for loop such
1570 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1571 -- entry in the scope stack. We don't bother to actually fix up the
1572 -- tree in this case since it's not worth the effort. Instead we just
1573 -- eat up the loop junk, leaving the entry for what now looks like an
1574 -- unmodified loop intact.
1576 if Loop_For_Flag and then Token = Tok_Semicolon then
1577 Error_Msg_SC ("LOOP belongs here, not before FOR");
1584 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1586 if No (Loop_Name) then
1588 Make_Identifier (Sloc (Loop_Node),
1589 Chars => Set_Loop_Block_Name ('L'));
1590 Set_Comes_From_Source (Created_Name, False);
1591 Set_Has_Created_Identifier (Loop_Node, True);
1592 Set_Identifier (Loop_Node, Created_Name);
1593 Scope.Table (Scope.Last).Labl := Created_Name;
1595 Set_Identifier (Loop_Node, Loop_Name);
1599 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1600 End_Statements (Loop_Node);
1601 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1602 Append_Elmt (Loop_Node, Label_List);
1605 end P_For_Statement;
1607 -- P_While_Statement
1609 -- This procedure scans a loop statement with a WHILE iteration scheme
1611 -- The caller has checked that the initial token is WHILE. The parameter
1612 -- is the node identifier for the block label if any (or is set to Empty
1613 -- if there is no block label).
1615 -- Error recovery: cannot raise Error_Resync
1617 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1618 Loop_Node : Node_Id;
1619 Iter_Scheme_Node : Node_Id;
1620 Loop_While_Flag : Boolean;
1621 Created_Name : Node_Id;
1625 Scope.Table (Scope.Last).Labl := Loop_Name;
1626 Scope.Table (Scope.Last).Ecol := Start_Column;
1627 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1628 Scope.Table (Scope.Last).Etyp := E_Loop;
1630 Loop_While_Flag := (Prev_Token = Tok_Loop);
1631 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1633 Set_Condition (Iter_Scheme_Node, P_Condition);
1635 -- The following is a special test so that a miswritten for loop such
1636 -- as "loop while I > 10;" is handled nicely, without making an extra
1637 -- entry in the scope stack. We don't bother to actually fix up the
1638 -- tree in this case since it's not worth the effort. Instead we just
1639 -- eat up the loop junk, leaving the entry for what now looks like an
1640 -- unmodified loop intact.
1642 if Loop_While_Flag and then Token = Tok_Semicolon then
1643 Error_Msg_SC ("LOOP belongs here, not before WHILE");
1650 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1653 if No (Loop_Name) then
1655 Make_Identifier (Sloc (Loop_Node),
1656 Chars => Set_Loop_Block_Name ('L'));
1657 Set_Comes_From_Source (Created_Name, False);
1658 Set_Has_Created_Identifier (Loop_Node, True);
1659 Set_Identifier (Loop_Node, Created_Name);
1660 Scope.Table (Scope.Last).Labl := Created_Name;
1662 Set_Identifier (Loop_Node, Loop_Name);
1665 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1666 End_Statements (Loop_Node);
1667 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1668 Append_Elmt (Loop_Node, Label_List);
1671 end P_While_Statement;
1673 ---------------------------------------
1674 -- 5.5 Loop Parameter Specification --
1675 ---------------------------------------
1677 -- LOOP_PARAMETER_SPECIFICATION ::=
1678 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1680 -- Error recovery: cannot raise Error_Resync
1682 function P_Loop_Parameter_Specification return Node_Id is
1683 Loop_Param_Specification_Node : Node_Id;
1686 Scan_State : Saved_Scan_State;
1689 Loop_Param_Specification_Node :=
1690 New_Node (N_Loop_Parameter_Specification, Token_Ptr);
1692 Save_Scan_State (Scan_State);
1693 ID_Node := P_Defining_Identifier (C_In);
1694 Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
1696 if Token = Tok_Left_Paren then
1697 Error_Msg_SC ("subscripted loop parameter not allowed");
1698 Restore_Scan_State (Scan_State);
1699 Discard_Junk_Node (P_Name);
1701 elsif Token = Tok_Dot then
1702 Error_Msg_SC ("selected loop parameter not allowed");
1703 Restore_Scan_State (Scan_State);
1704 Discard_Junk_Node (P_Name);
1709 if Token = Tok_Reverse then
1710 Scan; -- past REVERSE
1711 Set_Reverse_Present (Loop_Param_Specification_Node, True);
1714 Set_Discrete_Subtype_Definition
1715 (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
1716 return Loop_Param_Specification_Node;
1719 when Error_Resync =>
1721 end P_Loop_Parameter_Specification;
1723 --------------------------
1724 -- 5.6 Block Statement --
1725 --------------------------
1727 -- BLOCK_STATEMENT ::=
1728 -- [block_STATEMENT_IDENTIFIER:]
1730 -- DECLARATIVE_PART]
1732 -- HANDLED_SEQUENCE_OF_STATEMENTS
1733 -- end [block_IDENTIFIER];
1735 -- The parsing of block statements is handled by one of the two functions
1736 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1737 -- a declare section is present
1739 -- P_Declare_Statement
1741 -- This function parses a block statement with DECLARE present
1743 -- The caller has checked that the initial token is DECLARE
1745 -- Error recovery: cannot raise Error_Resync
1747 function P_Declare_Statement
1748 (Block_Name : Node_Id := Empty)
1751 Block_Node : Node_Id;
1752 Created_Name : Node_Id;
1755 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1758 Scope.Table (Scope.Last).Etyp := E_Name;
1759 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1760 Scope.Table (Scope.Last).Ecol := Start_Column;
1761 Scope.Table (Scope.Last).Labl := Block_Name;
1762 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1764 Scan; -- past DECLARE
1766 if No (Block_Name) then
1768 Make_Identifier (Sloc (Block_Node),
1769 Chars => Set_Loop_Block_Name ('B'));
1770 Set_Comes_From_Source (Created_Name, False);
1771 Set_Has_Created_Identifier (Block_Node, True);
1772 Set_Identifier (Block_Node, Created_Name);
1773 Scope.Table (Scope.Last).Labl := Created_Name;
1775 Set_Identifier (Block_Node, Block_Name);
1778 Append_Elmt (Block_Node, Label_List);
1779 Parse_Decls_Begin_End (Block_Node);
1781 end P_Declare_Statement;
1783 -- P_Begin_Statement
1785 -- This function parses a block statement with no DECLARE present
1787 -- The caller has checked that the initial token is BEGIN
1789 -- Error recovery: cannot raise Error_Resync
1791 function P_Begin_Statement
1792 (Block_Name : Node_Id := Empty)
1795 Block_Node : Node_Id;
1796 Created_Name : Node_Id;
1799 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1802 Scope.Table (Scope.Last).Etyp := E_Name;
1803 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1804 Scope.Table (Scope.Last).Ecol := Start_Column;
1805 Scope.Table (Scope.Last).Labl := Block_Name;
1806 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1808 if No (Block_Name) then
1810 Make_Identifier (Sloc (Block_Node),
1811 Chars => Set_Loop_Block_Name ('B'));
1812 Set_Comes_From_Source (Created_Name, False);
1813 Set_Has_Created_Identifier (Block_Node, True);
1814 Set_Identifier (Block_Node, Created_Name);
1815 Scope.Table (Scope.Last).Labl := Created_Name;
1817 Set_Identifier (Block_Node, Block_Name);
1820 Append_Elmt (Block_Node, Label_List);
1822 Scope.Table (Scope.Last).Ecol := Start_Column;
1823 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1825 Set_Handled_Statement_Sequence
1826 (Block_Node, P_Handled_Sequence_Of_Statements);
1827 End_Statements (Handled_Statement_Sequence (Block_Node));
1829 end P_Begin_Statement;
1831 -------------------------
1832 -- 5.7 Exit Statement --
1833 -------------------------
1835 -- EXIT_STATEMENT ::=
1836 -- exit [loop_NAME] [when CONDITION];
1838 -- The caller has checked that the initial token is EXIT
1840 -- Error recovery: can raise Error_Resync
1842 function P_Exit_Statement return Node_Id is
1843 Exit_Node : Node_Id;
1845 function Missing_Semicolon_On_Exit return Boolean;
1846 -- This function deals with the following specialized situation
1849 -- exit [identifier]
1852 -- This looks like a messed up EXIT WHEN, when in fact the problem
1853 -- is a missing semicolon. It is called with Token pointing to the
1854 -- WHEN token, and returns True if a semicolon is missing before
1855 -- the WHEN as in the above example.
1857 -------------------------------
1858 -- Missing_Semicolon_On_Exit --
1859 -------------------------------
1861 function Missing_Semicolon_On_Exit return Boolean is
1862 State : Saved_Scan_State;
1865 if not Token_Is_At_Start_Of_Line then
1868 elsif Scope.Table (Scope.Last).Etyp /= E_Case then
1872 Save_Scan_State (State);
1874 Scan; -- past token after WHEN
1876 if Token = Tok_Arrow then
1877 Restore_Scan_State (State);
1880 Restore_Scan_State (State);
1884 end Missing_Semicolon_On_Exit;
1886 -- Start of processing for P_Exit_Statement
1889 Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
1892 if Token = Tok_Identifier then
1893 Set_Name (Exit_Node, P_Qualified_Simple_Name);
1895 elsif Style_Check then
1896 -- This EXIT has no name, so check that
1897 -- the innermost loop is unnamed too.
1899 Check_No_Exit_Name :
1900 for J in reverse 1 .. Scope.Last loop
1901 if Scope.Table (J).Etyp = E_Loop then
1902 if Present (Scope.Table (J).Labl)
1903 and then Comes_From_Source (Scope.Table (J).Labl)
1905 -- Innermost loop in fact had a name, style check fails
1907 Style.No_Exit_Name (Scope.Table (J).Labl);
1910 exit Check_No_Exit_Name;
1912 end loop Check_No_Exit_Name;
1915 if Token = Tok_When and then not Missing_Semicolon_On_Exit then
1917 Set_Condition (Exit_Node, P_Condition);
1919 -- Allow IF instead of WHEN, giving error message
1921 elsif Token = Tok_If then
1923 Scan; -- past IF used in place of WHEN
1924 Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
1929 end P_Exit_Statement;
1931 -------------------------
1932 -- 5.8 Goto Statement --
1933 -------------------------
1935 -- GOTO_STATEMENT ::= goto label_NAME;
1937 -- The caller has checked that the initial token is GOTO (or TO in the
1938 -- error case where GO and TO were incorrectly separated).
1940 -- Error recovery: can raise Error_Resync
1942 function P_Goto_Statement return Node_Id is
1943 Goto_Node : Node_Id;
1946 Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
1947 Scan; -- past GOTO (or TO)
1948 Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
1949 Append_Elmt (Goto_Node, Goto_List);
1953 end P_Goto_Statement;
1955 ---------------------------
1956 -- Parse_Decls_Begin_End --
1957 ---------------------------
1959 -- This function parses the construct:
1963 -- HANDLED_SEQUENCE_OF_STATEMENTS
1966 -- The caller has built the scope stack entry, and created the node to
1967 -- whose Declarations and Handled_Statement_Sequence fields are to be
1968 -- set. On return these fields are filled in (except in the case of a
1969 -- task body, where the handled statement sequence is optional, and may
1970 -- thus be Empty), and the scan is positioned past the End sequence.
1972 -- If the BEGIN is missing, then the parent node is used to help construct
1973 -- an appropriate missing BEGIN message. Possibilities for the parent are:
1975 -- N_Block_Statement declare block
1976 -- N_Entry_Body entry body
1977 -- N_Package_Body package body (begin part optional)
1978 -- N_Subprogram_Body procedure or function body
1979 -- N_Task_Body task body
1981 -- Note: in the case of a block statement, there is definitely a DECLARE
1982 -- present (because a Begin statement without a DECLARE is handled by the
1983 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
1985 -- Error recovery: cannot raise Error_Resync
1987 procedure Parse_Decls_Begin_End (Parent : Node_Id) is
1988 Body_Decl : Node_Id;
1989 Body_Sloc : Source_Ptr;
1992 Parent_Nkind : Node_Kind;
1993 Spec_Node : Node_Id;
1996 procedure Missing_Begin (Msg : String);
1997 -- Called to post a missing begin message. In the normal case this is
1998 -- posted at the start of the current token. A special case arises when
1999 -- P_Declarative_Items has previously found a missing begin, in which
2000 -- case we replace the original error message.
2002 procedure Set_Null_HSS (Parent : Node_Id);
2003 -- Construct an empty handled statement sequence and install in Parent
2004 -- Leaves HSS set to reference the newly constructed statement sequence.
2010 procedure Missing_Begin (Msg : String) is
2012 if Missing_Begin_Msg = No_Error_Msg then
2015 Change_Error_Text (Missing_Begin_Msg, Msg);
2017 -- Purge any messages issued after than, since a missing begin
2018 -- can cause a lot of havoc, and it is better not to dump these
2019 -- cascaded messages on the user.
2021 Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
2029 procedure Set_Null_HSS (Parent : Node_Id) is
2034 Make_Null_Statement (Token_Ptr);
2035 Set_Comes_From_Source (Null_Stm, False);
2038 Make_Handled_Sequence_Of_Statements (Token_Ptr,
2039 Statements => New_List (Null_Stm));
2040 Set_Comes_From_Source (HSS, False);
2042 Set_Handled_Statement_Sequence (Parent, HSS);
2045 -- Start of processing for Parse_Decls_Begin_End
2048 Decls := P_Declarative_Part;
2050 -- Check for misplacement of later vs basic declarations in Ada 83
2052 if Ada_Version = Ada_83 then
2053 Decl := First (Decls);
2055 -- Loop through sequence of basic declarative items
2057 Outer : while Present (Decl) loop
2058 if Nkind (Decl) /= N_Subprogram_Body
2059 and then Nkind (Decl) /= N_Package_Body
2060 and then Nkind (Decl) /= N_Task_Body
2061 and then Nkind (Decl) not in N_Body_Stub
2065 -- Once a body is encountered, we only allow later declarative
2066 -- items. The inner loop checks the rest of the list.
2069 Body_Sloc := Sloc (Decl);
2071 Inner : while Present (Decl) loop
2072 if Nkind (Decl) not in N_Later_Decl_Item
2073 and then Nkind (Decl) /= N_Pragma
2075 if Ada_Version = Ada_83 then
2076 Error_Msg_Sloc := Body_Sloc;
2078 ("(Ada 83) decl cannot appear after body#", Decl);
2088 -- Here is where we deal with the case of IS used instead of semicolon.
2089 -- Specifically, if the last declaration in the declarative part is a
2090 -- subprogram body still marked as having a bad IS, then this is where
2091 -- we decide that the IS should really have been a semicolon and that
2092 -- the body should have been a declaration. Note that if the bad IS
2093 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2094 -- then the Bad_Is_Detected flag would have been reset by now.
2096 Body_Decl := Last (Decls);
2098 if Present (Body_Decl)
2099 and then Nkind (Body_Decl) = N_Subprogram_Body
2100 and then Bad_Is_Detected (Body_Decl)
2102 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2103 -- What we have now is a subprogram body with attached declarations
2104 -- and a possible statement sequence.
2106 -- First step is to take the declarations that were part of the bogus
2107 -- subprogram body and append them to the outer declaration chain.
2108 -- In other words we append them past the body (which we will later
2109 -- convert into a declaration).
2111 Append_List (Declarations (Body_Decl), Decls);
2113 -- Now take the handled statement sequence of the bogus body and
2114 -- set it as the statement sequence for the outer construct. Note
2115 -- that it may be empty (we specially allowed a missing BEGIN for
2116 -- a subprogram body marked as having a bad IS -- see below).
2118 Set_Handled_Statement_Sequence (Parent,
2119 Handled_Statement_Sequence (Body_Decl));
2121 -- Next step is to convert the old body node to a declaration node
2123 Spec_Node := Specification (Body_Decl);
2124 Change_Node (Body_Decl, N_Subprogram_Declaration);
2125 Set_Specification (Body_Decl, Spec_Node);
2127 -- Final step is to put the declarations for the parent where
2128 -- they belong, and then fall through the IF to scan out the
2131 Set_Declarations (Parent, Decls);
2133 -- This is the normal case (i.e. any case except the bad IS case)
2134 -- If we have a BEGIN, then scan out the sequence of statements, and
2135 -- also reset the expected column for the END to match the BEGIN.
2138 Set_Declarations (Parent, Decls);
2140 if Token = Tok_Begin then
2142 Style.Check_Indentation;
2145 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
2148 and then Token_Is_At_Start_Of_Line
2149 and then Start_Column /= Error_Msg_Col
2151 Error_Msg_SC ("(style) BEGIN in wrong column, should be@");
2154 Scope.Table (Scope.Last).Ecol := Start_Column;
2157 Scope.Table (Scope.Last).Sloc := Token_Ptr;
2159 Set_Handled_Statement_Sequence (Parent,
2160 P_Handled_Sequence_Of_Statements);
2165 Parent_Nkind := Nkind (Parent);
2167 -- A special check for the missing IS case. If we have a
2168 -- subprogram body that was marked as having a suspicious
2169 -- IS, and the current token is END, then we simply confirm
2170 -- the suspicion, and do not require a BEGIN to be present
2172 if Parent_Nkind = N_Subprogram_Body
2173 and then Token = Tok_End
2174 and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is
2176 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
2178 -- Otherwise BEGIN is not required for a package body, so we
2179 -- don't mind if it is missing, but we do construct a dummy
2180 -- one (so that we have somewhere to set End_Label).
2182 -- However if we have something other than a BEGIN which
2183 -- looks like it might be statements, then we signal a missing
2184 -- BEGIN for these cases as well. We define "something which
2185 -- looks like it might be statements" as a token other than
2186 -- END, EOF, or a token which starts declarations.
2188 elsif Parent_Nkind = N_Package_Body
2189 and then (Token = Tok_End
2190 or else Token = Tok_EOF
2191 or else Token in Token_Class_Declk)
2193 Set_Null_HSS (Parent);
2195 -- These are cases in which a BEGIN is required and not present
2198 Set_Null_HSS (Parent);
2200 -- Prepare to issue error message
2202 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
2203 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
2205 -- Now issue appropriate message
2207 if Parent_Nkind = N_Block_Statement then
2208 Missing_Begin ("missing BEGIN for DECLARE#!");
2210 elsif Parent_Nkind = N_Entry_Body then
2211 Missing_Begin ("missing BEGIN for ENTRY#!");
2213 elsif Parent_Nkind = N_Subprogram_Body then
2214 if Nkind (Specification (Parent))
2215 = N_Function_Specification
2217 Missing_Begin ("missing BEGIN for function&#!");
2219 Missing_Begin ("missing BEGIN for procedure&#!");
2222 -- The case for package body arises only when
2223 -- we have possible statement junk present.
2225 elsif Parent_Nkind = N_Package_Body then
2226 Missing_Begin ("missing BEGIN for package body&#!");
2229 pragma Assert (Parent_Nkind = N_Task_Body);
2230 Missing_Begin ("missing BEGIN for task body&#!");
2233 -- Here we pick up the statements after the BEGIN that
2234 -- should have been present but was not. We don't insist
2235 -- on statements being present if P_Declarative_Part had
2236 -- already found a missing BEGIN, since it might have
2237 -- swallowed a lone statement into the declarative part.
2239 if Missing_Begin_Msg /= No_Error_Msg
2240 and then Token = Tok_End
2244 Set_Handled_Statement_Sequence (Parent,
2245 P_Handled_Sequence_Of_Statements);
2251 -- Here with declarations and handled statement sequence scanned
2253 if Present (Handled_Statement_Sequence (Parent)) then
2254 End_Statements (Handled_Statement_Sequence (Parent));
2259 -- We know that End_Statements removed an entry from the scope stack
2260 -- (because it is required to do so under all circumstances). We can
2261 -- therefore reference the entry it removed one past the stack top.
2262 -- What we are interested in is whether it was a case of a bad IS.
2264 if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
2265 Error_Msg -- CODEFIX
2266 ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
2267 Set_Bad_Is_Detected (Parent, True);
2270 end Parse_Decls_Begin_End;
2272 -------------------------
2273 -- Set_Loop_Block_Name --
2274 -------------------------
2276 function Set_Loop_Block_Name (L : Character) return Name_Id is
2278 Name_Buffer (1) := L;
2279 Name_Buffer (2) := '_';
2281 Loop_Block_Count := Loop_Block_Count + 1;
2282 Add_Nat_To_Name_Buffer (Loop_Block_Count);
2284 end Set_Loop_Block_Name;
2290 procedure Then_Scan is
2294 while Token = Tok_Then loop
2295 Error_Msg_SC -- CODEFIX
2300 if Token = Tok_And or else Token = Tok_Or then
2301 Error_Msg_SC ("unexpected logical operator");
2302 Scan; -- past logical operator
2304 if (Prev_Token = Tok_And and then Token = Tok_Then)
2306 (Prev_Token = Tok_Or and then Token = Tok_Else)
2311 Discard_Junk_Node (P_Expression);
2314 if Token = Tok_Then then