1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks (All_Checks);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical
33 -- Local functions, used only in this chapter
35 function P_Case_Statement return Node_Id;
36 function P_Case_Statement_Alternative return Node_Id;
37 function P_Condition return Node_Id;
38 function P_Exit_Statement return Node_Id;
39 function P_Goto_Statement return Node_Id;
40 function P_If_Statement return Node_Id;
41 function P_Label return Node_Id;
42 function P_Loop_Parameter_Specification return Node_Id;
43 function P_Null_Statement return Node_Id;
45 function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
46 -- Parse assignment statement. On entry, the caller has scanned the left
47 -- hand side (passed in as Lhs), and the colon-equal (or some symbol
48 -- taken to be an error equivalent such as equal).
50 function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id;
51 -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is
52 -- the N_Identifier node for the label on the block. If Block_Name is
53 -- Empty on entry (the default), then the block statement is unlabeled.
55 function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id;
56 -- Parse declare block. If Block_Name is non-Empty on entry, it is
57 -- the N_Identifier node for the label on the block. If Block_Name is
58 -- Empty on entry (the default), then the block statement is unlabeled.
60 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
61 -- Parse for statement. If Loop_Name is non-Empty on entry, it is
62 -- the N_Identifier node for the label on the loop. If Loop_Name is
63 -- Empty on entry (the default), then the for statement is unlabeled.
65 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
66 -- Parse loop statement. If Loop_Name is non-Empty on entry, it is
67 -- the N_Identifier node for the label on the loop. If Loop_Name is
68 -- Empty on entry (the default), then the loop statement is unlabeled.
70 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
71 -- Parse while statement. If Loop_Name is non-Empty on entry, it is
72 -- the N_Identifier node for the label on the loop. If Loop_Name is
73 -- Empty on entry (the default), then the while statement is unlabeled.
75 function Set_Loop_Block_Name (L : Character) return Name_Id;
76 -- Given a letter 'L' for a loop or 'B' for a block, returns a name
77 -- of the form L_nn or B_nn where nn is a serial number obtained by
78 -- incrementing the variable Loop_Block_Count.
81 -- Scan past THEN token, testing for illegal junk after it
83 ---------------------------------
84 -- 5.1 Sequence of Statements --
85 ---------------------------------
87 -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT}
90 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
92 -- SIMPLE_STATEMENT ::= NULL_STATEMENT
93 -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT
94 -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT
95 -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT
96 -- | REQUEUE_STATEMENT | DELAY_STATEMENT
97 -- | ABORT_STATEMENT | RAISE_STATEMENT
100 -- COMPOUND_STATEMENT ::=
101 -- IF_STATEMENT | CASE_STATEMENT
102 -- | LOOP_STATEMENT | BLOCK_STATEMENT
103 -- | ACCEPT_STATEMENT | SELECT_STATEMENT
105 -- This procedure scans a sequence of statements. The caller sets SS_Flags
106 -- to indicate acceptable termination conditions for the sequence:
108 -- SS_Flags.Eftm Terminate on ELSIF
109 -- SS_Flags.Eltm Terminate on ELSE
110 -- SS_Flags.Extm Terminate on EXCEPTION
111 -- SS_Flags.Ortm Terminate on OR
112 -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return)
113 -- SS_Flags.Whtm Terminate on WHEN
114 -- SS_Flags.Unco Unconditional terminate after scanning one statement
116 -- In addition, the scan is always terminated by encountering END or the
117 -- end of file (EOF) condition. If one of the six above terminators is
118 -- encountered with the corresponding SS_Flags flag not set, then the
119 -- action taken is as follows:
121 -- If the keyword occurs to the left of the expected column of the end
122 -- for the current sequence (as recorded in the current end context),
123 -- then it is assumed to belong to an outer context, and is considered
124 -- to terminate the sequence of statements.
126 -- If the keyword occurs to the right of, or in the expected column of
127 -- the end for the current sequence, then an error message is output,
128 -- the keyword together with its associated context is skipped, and
129 -- the statement scan continues until another terminator is found.
131 -- Note that the first action means that control can return to the caller
132 -- with Token set to a terminator other than one of those specified by the
133 -- SS parameter. The caller should treat such a case as equivalent to END.
135 -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at
136 -- least one real statement (other than a pragma) is required in the
137 -- statement sequence. During the processing of the sequence, this
138 -- flag is manipulated to indicate the current status of the requirement
139 -- for a statement. For example, it is turned off by the occurrence of a
140 -- statement, and back on by a label (which requires a following statement)
142 -- Error recovery: cannot raise Error_Resync. If an error occurs during
143 -- parsing a statement, then the scan pointer is advanced past the next
144 -- semicolon and the parse continues.
146 function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is
148 Statement_Required : Boolean;
149 -- This flag indicates if a subsequent statement (other than a pragma)
150 -- is required. It is initialized from the Sreq flag, and modified as
151 -- statements are scanned (a statement turns it off, and a label turns
152 -- it back on again since a statement must follow a label).
154 Declaration_Found : Boolean := False;
155 -- This flag is set True if a declaration is encountered, so that the
156 -- error message about declarations in the statement part is only
157 -- given once for a given sequence of statements.
159 Scan_State_Label : Saved_Scan_State;
160 Scan_State : Saved_Scan_State;
162 Statement_List : List_Id;
163 Block_Label : Name_Id;
167 procedure Junk_Declaration;
168 -- Procedure called to handle error of declaration encountered in
169 -- statement sequence.
171 procedure Test_Statement_Required;
172 -- Flag error if Statement_Required flag set
174 ----------------------
175 -- Junk_Declaration --
176 ----------------------
178 procedure Junk_Declaration is
180 if (not Declaration_Found) or All_Errors_Mode then
181 Error_Msg_SC -- CODEFIX
182 ("declarations must come before BEGIN");
183 Declaration_Found := True;
186 Skip_Declaration (Statement_List);
187 end Junk_Declaration;
189 -----------------------------
190 -- Test_Statement_Required --
191 -----------------------------
193 procedure Test_Statement_Required is
195 if Statement_Required then
197 -- Check no statement required after label in Ada 2012
199 if Ada_Version >= Ada_2012
200 and then not Is_Empty_List (Statement_List)
201 and then Nkind (Last (Statement_List)) = N_Label
204 Null_Stm : constant Node_Id :=
205 Make_Null_Statement (Token_Ptr);
207 Set_Comes_From_Source (Null_Stm, False);
208 Append_To (Statement_List, Null_Stm);
211 -- If not Ada 2012, or not special case above, give error message
214 Error_Msg_BC -- CODEFIX
215 ("statement expected");
218 end Test_Statement_Required;
220 -- Start of processing for P_Sequence_Of_Statements
223 Statement_List := New_List;
224 Statement_Required := SS_Flags.Sreq;
227 Ignore (Tok_Semicolon);
231 Style.Check_Indentation;
234 -- Deal with reserved identifier (in assignment or call)
236 if Is_Reserved_Identifier then
237 Save_Scan_State (Scan_State); -- at possible bad identifier
238 Scan; -- and scan past it
240 -- We have an reserved word which is spelled in identifier
241 -- style, so the question is whether it really is intended
242 -- to be an identifier.
245 -- If followed by a semicolon, then it is an identifier,
246 -- with the exception of the cases tested for below.
248 (Token = Tok_Semicolon
249 and then Prev_Token /= Tok_Return
250 and then Prev_Token /= Tok_Null
251 and then Prev_Token /= Tok_Raise
252 and then Prev_Token /= Tok_End
253 and then Prev_Token /= Tok_Exit)
255 -- If followed by colon, colon-equal, or dot, then we
256 -- definitely have an identifier (could not be reserved)
258 or else Token = Tok_Colon
259 or else Token = Tok_Colon_Equal
260 or else Token = Tok_Dot
262 -- Left paren means we have an identifier except for those
263 -- reserved words that can legitimately be followed by a
267 (Token = Tok_Left_Paren
268 and then Prev_Token /= Tok_Case
269 and then Prev_Token /= Tok_Delay
270 and then Prev_Token /= Tok_If
271 and then Prev_Token /= Tok_Elsif
272 and then Prev_Token /= Tok_Return
273 and then Prev_Token /= Tok_When
274 and then Prev_Token /= Tok_While
275 and then Prev_Token /= Tok_Separate)
277 -- Here we have an apparent reserved identifier and the
278 -- token past it is appropriate to this usage (and would
279 -- be a definite error if this is not an identifier). What
280 -- we do is to use P_Identifier to fix up the identifier,
281 -- and then fall into the normal processing.
283 Restore_Scan_State (Scan_State); -- back to the ID
284 Scan_Reserved_Identifier (Force_Msg => False);
286 -- Not a reserved identifier after all (or at least we can't
287 -- be sure that it is), so reset the scan and continue.
290 Restore_Scan_State (Scan_State); -- back to the reserved word
294 -- Now look to see what kind of statement we have
298 -- Case of end or EOF
300 when Tok_End | Tok_EOF =>
302 -- These tokens always terminate the statement sequence
304 Test_Statement_Required;
311 -- Terminate if Eftm set or if the ELSIF is to the left
312 -- of the expected column of the end for this sequence
315 or else Start_Column < Scope.Table (Scope.Last).Ecol
317 Test_Statement_Required;
320 -- Otherwise complain and skip past ELSIF Condition then
323 Error_Msg_SC ("ELSIF not allowed here");
325 Discard_Junk_Node (P_Expression_No_Right_Paren);
327 Statement_Required := False;
334 -- Terminate if Eltm set or if the else is to the left
335 -- of the expected column of the end for this sequence
338 or else Start_Column < Scope.Table (Scope.Last).Ecol
340 Test_Statement_Required;
343 -- Otherwise complain and skip past else
346 Error_Msg_SC ("ELSE not allowed here");
348 Statement_Required := False;
353 when Tok_Exception =>
354 Test_Statement_Required;
356 -- If Extm not set and the exception is not to the left of
357 -- the expected column of the end for this sequence, then we
358 -- assume it belongs to the current sequence, even though it
361 if not SS_Flags.Extm and then
362 Start_Column >= Scope.Table (Scope.Last).Ecol
365 Error_Msg_SC ("exception handler not permitted here");
366 Scan; -- past EXCEPTION
367 Discard_Junk_List (Parse_Exception_Handlers);
370 -- Always return, in the case where we scanned out handlers
371 -- that we did not expect, Parse_Exception_Handlers returned
372 -- with Token being either end or EOF, so we are OK.
380 -- Terminate if Ortm set or if the or is to the left of the
381 -- expected column of the end for this sequence.
384 or else Start_Column < Scope.Table (Scope.Last).Ecol
386 Test_Statement_Required;
389 -- Otherwise complain and skip past or
392 Error_Msg_SC ("OR not allowed here");
394 Statement_Required := False;
397 -- Case of THEN (deal also with THEN ABORT)
400 Save_Scan_State (Scan_State); -- at THEN
403 -- Terminate if THEN ABORT allowed (ATC case)
405 exit when SS_Flags.Tatm and then Token = Tok_Abort;
407 -- Otherwise we treat THEN as some kind of mess where we did
408 -- not see the associated IF, but we pick up assuming it had
411 Restore_Scan_State (Scan_State); -- to THEN
412 Append_To (Statement_List, P_If_Statement);
413 Statement_Required := False;
415 -- Case of WHEN (error because we are not in a case)
417 when Tok_When | Tok_Others =>
419 -- Terminate if Whtm set or if the WHEN is to the left of
420 -- the expected column of the end for this sequence.
423 or else Start_Column < Scope.Table (Scope.Last).Ecol
425 Test_Statement_Required;
428 -- Otherwise complain and skip when Choice {| Choice} =>
431 Error_Msg_SC ("WHEN not allowed here");
433 Discard_Junk_List (P_Discrete_Choice_List);
435 Statement_Required := False;
438 -- Cases of statements starting with an identifier
440 when Tok_Identifier =>
443 -- Save scan pointers and line number in case block label
445 Id_Node := Token_Node;
446 Block_Label := Token_Name;
447 Save_Scan_State (Scan_State_Label); -- at possible label
450 -- Check for common case of assignment, since it occurs
451 -- frequently, and we want to process it efficiently.
453 if Token = Tok_Colon_Equal then
454 Scan; -- past the colon-equal
455 Append_To (Statement_List,
456 P_Assignment_Statement (Id_Node));
457 Statement_Required := False;
459 -- Check common case of procedure call, another case that
460 -- we want to speed up as much as possible.
462 elsif Token = Tok_Semicolon then
463 Append_To (Statement_List,
464 P_Statement_Name (Id_Node));
465 Scan; -- past semicolon
466 Statement_Required := False;
468 -- Check for case of "go to" in place of "goto"
470 elsif Token = Tok_Identifier
471 and then Block_Label = Name_Go
472 and then Token_Name = Name_To
474 Error_Msg_SP -- CODEFIX
475 ("goto is one word");
476 Append_To (Statement_List, P_Goto_Statement);
477 Statement_Required := False;
479 -- Check common case of = used instead of :=, just so we
480 -- give a better error message for this special misuse.
482 elsif Token = Tok_Equal then
483 T_Colon_Equal; -- give := expected message
484 Append_To (Statement_List,
485 P_Assignment_Statement (Id_Node));
486 Statement_Required := False;
488 -- Check case of loop label or block label
490 elsif Token = Tok_Colon
491 or else (Token in Token_Class_Labeled_Stmt
492 and then not Token_Is_At_Start_Of_Line)
494 T_Colon; -- past colon (if there, or msg for missing one)
496 -- Test for more than one label
499 exit when Token /= Tok_Identifier;
500 Save_Scan_State (Scan_State); -- at second Id
503 if Token = Tok_Colon then
505 ("only one label allowed on block or loop");
506 Scan; -- past colon on extra label
508 -- Use the second label as the "real" label
510 Scan_State_Label := Scan_State;
512 -- We will set Error_name as the Block_Label since
513 -- we really don't know which of the labels might
514 -- be used at the end of the loop or block!
516 Block_Label := Error_Name;
518 -- If Id with no colon, then backup to point to the
519 -- Id and we will issue the message below when we try
520 -- to scan out the statement as some other form.
523 Restore_Scan_State (Scan_State); -- to second Id
528 -- Loop_Statement (labeled Loop_Statement)
530 if Token = Tok_Loop then
531 Append_To (Statement_List,
532 P_Loop_Statement (Id_Node));
534 -- While statement (labeled loop statement with WHILE)
536 elsif Token = Tok_While then
537 Append_To (Statement_List,
538 P_While_Statement (Id_Node));
540 -- Declare statement (labeled block statement with
543 elsif Token = Tok_Declare then
544 Append_To (Statement_List,
545 P_Declare_Statement (Id_Node));
547 -- Begin statement (labeled block statement with no
550 elsif Token = Tok_Begin then
551 Append_To (Statement_List,
552 P_Begin_Statement (Id_Node));
554 -- For statement (labeled loop statement with FOR)
556 elsif Token = Tok_For then
557 Append_To (Statement_List,
558 P_For_Statement (Id_Node));
560 -- Improper statement follows label. If we have an
561 -- expression token, then assume the colon was part
562 -- of a misplaced declaration.
564 elsif Token not in Token_Class_Eterm then
565 Restore_Scan_State (Scan_State_Label);
568 -- Otherwise complain we have inappropriate statement
572 ("loop or block statement must follow label");
575 Statement_Required := False;
577 -- Here we have an identifier followed by something
578 -- other than a colon, semicolon or assignment symbol.
579 -- The only valid possibility is a name extension symbol
581 elsif Token in Token_Class_Namext then
582 Restore_Scan_State (Scan_State_Label); -- to Id
585 -- Skip junk right parens in this context
587 Ignore (Tok_Right_Paren);
589 -- Check context following call
591 if Token = Tok_Colon_Equal then
592 Scan; -- past colon equal
593 Append_To (Statement_List,
594 P_Assignment_Statement (Name_Node));
595 Statement_Required := False;
597 -- Check common case of = used instead of :=
599 elsif Token = Tok_Equal then
600 T_Colon_Equal; -- give := expected message
601 Append_To (Statement_List,
602 P_Assignment_Statement (Name_Node));
603 Statement_Required := False;
605 -- Check apostrophe cases
607 elsif Token = Tok_Apostrophe then
608 Append_To (Statement_List,
609 P_Code_Statement (Name_Node));
610 Statement_Required := False;
612 -- The only other valid item after a name is ; which
613 -- means that the item we just scanned was a call.
615 elsif Token = Tok_Semicolon then
616 Append_To (Statement_List,
617 P_Statement_Name (Name_Node));
618 Scan; -- past semicolon
619 Statement_Required := False;
621 -- A slash following an identifier or a selected
622 -- component in this situation is most likely a period
623 -- (see location of keys on keyboard).
625 elsif Token = Tok_Slash
626 and then (Nkind (Name_Node) = N_Identifier
628 Nkind (Name_Node) = N_Selected_Component)
630 Error_Msg_SC -- CODEFIX
631 ("""/"" should be "".""");
632 Statement_Required := False;
635 -- Else we have a missing semicolon
639 Statement_Required := False;
642 -- If junk after identifier, check if identifier is an
643 -- instance of an incorrectly spelled keyword. If so, we
644 -- do nothing. The Bad_Spelling_Of will have reset Token
645 -- to the appropriate keyword, so the next time round the
646 -- loop we will process the modified token. Note that we
647 -- check for ELSIF before ELSE here. That's not accidental.
648 -- We don't want to identify a misspelling of ELSE as
649 -- ELSIF, and in particular we do not want to treat ELSEIF
653 Restore_Scan_State (Scan_State_Label); -- to identifier
655 if Bad_Spelling_Of (Tok_Abort)
656 or else Bad_Spelling_Of (Tok_Accept)
657 or else Bad_Spelling_Of (Tok_Case)
658 or else Bad_Spelling_Of (Tok_Declare)
659 or else Bad_Spelling_Of (Tok_Delay)
660 or else Bad_Spelling_Of (Tok_Elsif)
661 or else Bad_Spelling_Of (Tok_Else)
662 or else Bad_Spelling_Of (Tok_End)
663 or else Bad_Spelling_Of (Tok_Exception)
664 or else Bad_Spelling_Of (Tok_Exit)
665 or else Bad_Spelling_Of (Tok_For)
666 or else Bad_Spelling_Of (Tok_Goto)
667 or else Bad_Spelling_Of (Tok_If)
668 or else Bad_Spelling_Of (Tok_Loop)
669 or else Bad_Spelling_Of (Tok_Or)
670 or else Bad_Spelling_Of (Tok_Pragma)
671 or else Bad_Spelling_Of (Tok_Raise)
672 or else Bad_Spelling_Of (Tok_Requeue)
673 or else Bad_Spelling_Of (Tok_Return)
674 or else Bad_Spelling_Of (Tok_Select)
675 or else Bad_Spelling_Of (Tok_When)
676 or else Bad_Spelling_Of (Tok_While)
680 -- If not a bad spelling, then we really have junk
683 Scan; -- past identifier again
685 -- If next token is first token on line, then we
686 -- consider that we were missing a semicolon after
687 -- the identifier, and process it as a procedure
688 -- call with no parameters.
690 if Token_Is_At_Start_Of_Line then
691 Append_To (Statement_List,
692 P_Statement_Name (Id_Node));
693 T_Semicolon; -- to give error message
694 Statement_Required := False;
696 -- Otherwise we give a missing := message and
697 -- simply abandon the junk that is there now.
700 T_Colon_Equal; -- give := expected message
707 -- Statement starting with operator symbol. This could be
708 -- a call, a name starting an assignment, or a qualified
711 when Tok_Operator_Symbol =>
715 -- An attempt at a range attribute or a qualified expression
716 -- must be illegal here (a code statement cannot possibly
717 -- allow qualification by a function name).
719 if Token = Tok_Apostrophe then
720 Error_Msg_SC ("apostrophe illegal here");
724 -- Scan possible assignment if we have a name
726 if Expr_Form = EF_Name
727 and then Token = Tok_Colon_Equal
729 Scan; -- past colon equal
730 Append_To (Statement_List,
731 P_Assignment_Statement (Name_Node));
733 Append_To (Statement_List,
734 P_Statement_Name (Name_Node));
738 Statement_Required := False;
740 -- Label starting with << which must precede real statement
742 when Tok_Less_Less =>
743 Append_To (Statement_List, P_Label);
744 Statement_Required := True;
746 -- Pragma appearing as a statement in a statement sequence
750 Append_To (Statement_List, P_Pragma);
756 Append_To (Statement_List, P_Abort_Statement);
757 Statement_Required := False;
763 Append_To (Statement_List, P_Accept_Statement);
764 Statement_Required := False;
766 -- Begin_Statement (Block_Statement with no declare, no label)
770 Append_To (Statement_List, P_Begin_Statement);
771 Statement_Required := False;
777 Append_To (Statement_List, P_Case_Statement);
778 Statement_Required := False;
780 -- Block_Statement with DECLARE and no label
784 Append_To (Statement_List, P_Declare_Statement);
785 Statement_Required := False;
791 Append_To (Statement_List, P_Delay_Statement);
792 Statement_Required := False;
798 Append_To (Statement_List, P_Exit_Statement);
799 Statement_Required := False;
801 -- Loop_Statement with FOR and no label
805 Append_To (Statement_List, P_For_Statement);
806 Statement_Required := False;
812 Append_To (Statement_List, P_Goto_Statement);
813 Statement_Required := False;
819 Append_To (Statement_List, P_If_Statement);
820 Statement_Required := False;
826 Append_To (Statement_List, P_Loop_Statement);
827 Statement_Required := False;
833 Append_To (Statement_List, P_Null_Statement);
834 Statement_Required := False;
840 Append_To (Statement_List, P_Raise_Statement);
841 Statement_Required := False;
847 Append_To (Statement_List, P_Requeue_Statement);
848 Statement_Required := False;
854 Append_To (Statement_List, P_Return_Statement);
855 Statement_Required := False;
861 Append_To (Statement_List, P_Select_Statement);
862 Statement_Required := False;
864 -- While_Statement (Block_Statement with while and no loop)
868 Append_To (Statement_List, P_While_Statement);
869 Statement_Required := False;
871 -- Anything else is some kind of junk, signal an error message
872 -- and then raise Error_Resync, to merge with the normal
873 -- handling of a bad statement.
877 if Token in Token_Class_Declk then
881 Error_Msg_BC -- CODEFIX
882 ("statement expected");
887 -- On error resynchronization, skip past next semicolon, and, since
888 -- we are still in the statement loop, look for next statement. We
889 -- set Statement_Required False to avoid an unnecessary error message
890 -- complaining that no statement was found (i.e. we consider the
891 -- junk to satisfy the requirement for a statement being present).
895 Resync_Past_Semicolon_Or_To_Loop_Or_Then;
896 Statement_Required := False;
899 exit when SS_Flags.Unco;
903 return Statement_List;
905 end P_Sequence_Of_Statements;
911 -- Parsed by P_Sequence_Of_Statements (5.1), except for the case
912 -- of a statement of the form of a name, which is handled here. The
913 -- argument passed in is the tree for the name which has been scanned
914 -- The returned value is the corresponding statement form.
916 -- This routine is also used by Par.Prag for processing the procedure
917 -- call that appears as the second argument of a pragma Assert.
919 -- Error recovery: cannot raise Error_Resync
921 function P_Statement_Name (Name_Node : Node_Id) return Node_Id is
925 -- Case of Indexed component, which is a procedure call with arguments
927 if Nkind (Name_Node) = N_Indexed_Component then
929 Prefix_Node : constant Node_Id := Prefix (Name_Node);
930 Exprs_Node : constant List_Id := Expressions (Name_Node);
933 Change_Node (Name_Node, N_Procedure_Call_Statement);
934 Set_Name (Name_Node, Prefix_Node);
935 Set_Parameter_Associations (Name_Node, Exprs_Node);
939 -- Case of function call node, which is a really a procedure call
941 elsif Nkind (Name_Node) = N_Function_Call then
943 Fname_Node : constant Node_Id := Name (Name_Node);
944 Params_List : constant List_Id :=
945 Parameter_Associations (Name_Node);
948 Change_Node (Name_Node, N_Procedure_Call_Statement);
949 Set_Name (Name_Node, Fname_Node);
950 Set_Parameter_Associations (Name_Node, Params_List);
954 -- Case of call to attribute that denotes a procedure. Here we
955 -- just leave the attribute reference unchanged.
957 elsif Nkind (Name_Node) = N_Attribute_Reference
958 and then Is_Procedure_Attribute_Name (Attribute_Name (Name_Node))
962 -- All other cases of names are parameterless procedure calls
966 New_Node (N_Procedure_Call_Statement, Sloc (Name_Node));
967 Set_Name (Stmt_Node, Name_Node);
971 end P_Statement_Name;
973 ---------------------------
974 -- 5.1 Simple Statement --
975 ---------------------------
977 -- Parsed by P_Sequence_Of_Statements (5.1)
979 -----------------------------
980 -- 5.1 Compound Statement --
981 -----------------------------
983 -- Parsed by P_Sequence_Of_Statements (5.1)
985 -------------------------
986 -- 5.1 Null Statement --
987 -------------------------
989 -- NULL_STATEMENT ::= null;
991 -- The caller has already checked that the current token is null
993 -- Error recovery: cannot raise Error_Resync
995 function P_Null_Statement return Node_Id is
996 Null_Stmt_Node : Node_Id;
999 Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr);
1002 return Null_Stmt_Node;
1003 end P_Null_Statement;
1009 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
1011 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
1013 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
1014 -- (not an OPERATOR_SYMBOL)
1016 -- The caller has already checked that the current token is <<
1018 -- Error recovery: can raise Error_Resync
1020 function P_Label return Node_Id is
1021 Label_Node : Node_Id;
1024 Label_Node := New_Node (N_Label, Token_Ptr);
1026 Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
1028 Append_Elmt (Label_Node, Label_List);
1032 -------------------------------
1033 -- 5.1 Statement Identifier --
1034 -------------------------------
1036 -- Statement label is parsed by P_Label (5.1)
1038 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1039 -- or P_While_Statement (5.5)
1041 -- Block label is parsed by P_Begin_Statement (5.6) or
1042 -- P_Declare_Statement (5.6)
1044 -------------------------------
1045 -- 5.2 Assignment Statement --
1046 -------------------------------
1048 -- ASSIGNMENT_STATEMENT ::=
1049 -- variable_NAME := EXPRESSION;
1051 -- Error recovery: can raise Error_Resync
1053 function P_Assignment_Statement (LHS : Node_Id) return Node_Id is
1054 Assign_Node : Node_Id;
1057 Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr);
1058 Set_Name (Assign_Node, LHS);
1059 Set_Expression (Assign_Node, P_Expression_No_Right_Paren);
1062 end P_Assignment_Statement;
1064 -----------------------
1065 -- 5.3 If Statement --
1066 -----------------------
1069 -- if CONDITION then
1070 -- SEQUENCE_OF_STATEMENTS
1071 -- {elsif CONDITION then
1072 -- SEQUENCE_OF_STATEMENTS}
1074 -- SEQUENCE_OF_STATEMENTS]
1077 -- The caller has checked that the initial token is IF (or in the error
1078 -- case of a mysterious THEN, the initial token may simply be THEN, in
1079 -- which case, no condition (or IF) was scanned).
1081 -- Error recovery: can raise Error_Resync
1083 function P_If_Statement return Node_Id is
1085 Elsif_Node : Node_Id;
1088 procedure Add_Elsif_Part;
1089 -- An internal procedure used to scan out a single ELSIF part. On entry
1090 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1091 -- scanned out and is in Prev_Token.
1093 procedure Check_If_Column;
1094 -- An internal procedure used to check that THEN, ELSE, or ELSIF
1095 -- appear in the right place if column checking is enabled (i.e. if
1096 -- they are the first token on the line, then they must appear in
1097 -- the same column as the opening IF).
1099 procedure Check_Then_Column;
1100 -- This procedure carries out the style checks for a THEN token
1101 -- Note that the caller has set Loc to the Source_Ptr value for
1102 -- the previous IF or ELSIF token. These checks apply only to a
1103 -- THEN at the start of a line.
1105 function Else_Should_Be_Elsif return Boolean;
1106 -- An internal routine used to do a special error recovery check when
1107 -- an ELSE is encountered. It determines if the ELSE should be treated
1108 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1109 -- is followed by a sequence of tokens, starting on the same line as
1110 -- the ELSE, which are not expression terminators, followed by a THEN.
1111 -- On entry, the ELSE has been scanned out.
1113 procedure Add_Elsif_Part is
1115 if No (Elsif_Parts (If_Node)) then
1116 Set_Elsif_Parts (If_Node, New_List);
1119 Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr);
1120 Loc := Prev_Token_Ptr;
1121 Set_Condition (Elsif_Node, P_Condition);
1125 (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1126 Append (Elsif_Node, Elsif_Parts (If_Node));
1129 procedure Check_If_Column is
1131 if RM_Column_Check and then Token_Is_At_Start_Of_Line
1132 and then Start_Column /= Scope.Table (Scope.Last).Ecol
1134 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
1135 Error_Msg_SC ("(style) this token should be@");
1137 end Check_If_Column;
1139 procedure Check_Then_Column is
1141 if Token_Is_At_Start_Of_Line and then Token = Tok_Then then
1145 Style.Check_Then (Loc);
1148 end Check_Then_Column;
1150 function Else_Should_Be_Elsif return Boolean is
1151 Scan_State : Saved_Scan_State;
1154 if Token_Is_At_Start_Of_Line then
1158 Save_Scan_State (Scan_State);
1161 if Token in Token_Class_Eterm then
1162 Restore_Scan_State (Scan_State);
1165 Scan; -- past non-expression terminating token
1167 if Token = Tok_Then then
1168 Restore_Scan_State (Scan_State);
1174 end Else_Should_Be_Elsif;
1176 -- Start of processing for P_If_Statement
1179 If_Node := New_Node (N_If_Statement, Token_Ptr);
1182 Scope.Table (Scope.Last).Etyp := E_If;
1183 Scope.Table (Scope.Last).Ecol := Start_Column;
1184 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1185 Scope.Table (Scope.Last).Labl := Error;
1186 Scope.Table (Scope.Last).Node := If_Node;
1188 if Token = Tok_If then
1191 Set_Condition (If_Node, P_Condition);
1193 -- Deal with misuse of IF expression => used instead
1194 -- of WHEN expression =>
1196 if Token = Tok_Arrow then
1197 Error_Msg_SC -- CODEFIX
1199 Scan; -- past the arrow
1200 Pop_Scope_Stack; -- remove unneeded entry
1207 Error_Msg_SC ("no IF for this THEN");
1208 Set_Condition (If_Node, Error);
1214 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1216 -- This loop scans out else and elsif parts
1219 if Token = Tok_Elsif then
1222 if Present (Else_Statements (If_Node)) then
1223 Error_Msg_SP ("ELSIF cannot appear after ELSE");
1229 elsif Token = Tok_Else then
1233 if Else_Should_Be_Elsif then
1234 Error_Msg_SP -- CODEFIX
1235 ("ELSE should be ELSIF");
1239 -- Here we have an else that really is an else
1241 if Present (Else_Statements (If_Node)) then
1242 Error_Msg_SP ("only one ELSE part allowed");
1244 (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
1245 Else_Statements (If_Node));
1248 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1252 -- If anything other than ELSE or ELSIF, exit the loop. The token
1253 -- had better be END (and in fact it had better be END IF), but
1254 -- we will let End_Statements take care of checking that.
1266 --------------------
1268 --------------------
1270 -- CONDITION ::= boolean_EXPRESSION
1272 function P_Condition return Node_Id is
1276 Cond := P_Expression_No_Right_Paren;
1278 -- It is never possible for := to follow a condition, so if we get
1279 -- a := we assume it is a mistyped equality. Note that we do not try
1280 -- to reconstruct the tree correctly in this case, but we do at least
1281 -- give an accurate error message.
1283 if Token = Tok_Colon_Equal then
1284 while Token = Tok_Colon_Equal loop
1285 Error_Msg_SC -- CODEFIX
1286 (""":="" should be ""=""");
1287 Scan; -- past junk :=
1288 Discard_Junk_Node (P_Expression_No_Right_Paren);
1293 -- Otherwise check for redundant parens
1297 and then Paren_Count (Cond) > 0
1299 Style.Check_Xtra_Parens (First_Sloc (Cond));
1302 -- And return the result
1308 -------------------------
1309 -- 5.4 Case Statement --
1310 -------------------------
1312 -- CASE_STATEMENT ::=
1313 -- case EXPRESSION is
1314 -- CASE_STATEMENT_ALTERNATIVE
1315 -- {CASE_STATEMENT_ALTERNATIVE}
1318 -- The caller has checked that the first token is CASE
1320 -- Can raise Error_Resync
1322 function P_Case_Statement return Node_Id is
1323 Case_Node : Node_Id;
1324 Alternatives_List : List_Id;
1325 First_When_Loc : Source_Ptr;
1328 Case_Node := New_Node (N_Case_Statement, Token_Ptr);
1331 Scope.Table (Scope.Last).Etyp := E_Case;
1332 Scope.Table (Scope.Last).Ecol := Start_Column;
1333 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1334 Scope.Table (Scope.Last).Labl := Error;
1335 Scope.Table (Scope.Last).Node := Case_Node;
1338 Set_Expression (Case_Node, P_Expression_No_Right_Paren);
1341 -- Prepare to parse case statement alternatives
1343 Alternatives_List := New_List;
1344 P_Pragmas_Opt (Alternatives_List);
1345 First_When_Loc := Token_Ptr;
1347 -- Loop through case statement alternatives
1350 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1351 -- that it is a semantic check to ensure the proper use of OTHERS
1353 if Token = Tok_When or else Token = Tok_Others then
1354 Append (P_Case_Statement_Alternative, Alternatives_List);
1356 -- If we have an END, then probably we are at the end of the case
1357 -- but we only exit if Check_End thinks the END was reasonable.
1359 elsif Token = Tok_End then
1360 exit when Check_End;
1362 -- Here if token is other than WHEN, OTHERS or END. We definitely
1363 -- have an error, but the question is whether or not to get out of
1364 -- the case statement. We don't want to get out early, or we will
1365 -- get a slew of junk error messages for subsequent when tokens.
1367 -- If the token is not at the start of the line, or if it is indented
1368 -- with respect to the current case statement, then the best guess is
1369 -- that we are still supposed to be inside the case statement. We
1370 -- complain about the missing WHEN, and discard the junk statements.
1372 elsif not Token_Is_At_Start_Of_Line
1373 or else Start_Column > Scope.Table (Scope.Last).Ecol
1375 Error_Msg_BC ("WHEN (case statement alternative) expected");
1377 -- Here is a possibility for infinite looping if we don't make
1378 -- progress. So try to process statements, otherwise exit
1381 Error_Ptr : constant Source_Ptr := Scan_Ptr;
1383 Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm));
1384 exit when Scan_Ptr = Error_Ptr and then Check_End;
1387 -- Here we have a junk token at the start of the line and it is
1388 -- not indented. If Check_End thinks there is a missing END, then
1389 -- we will get out of the case, otherwise we keep going.
1392 exit when Check_End;
1396 -- Make sure we have at least one alternative
1398 if No (First_Non_Pragma (Alternatives_List)) then
1400 ("WHEN expected, must have at least one alternative in case",
1405 Set_Alternatives (Case_Node, Alternatives_List);
1408 end P_Case_Statement;
1410 -------------------------------------
1411 -- 5.4 Case Statement Alternative --
1412 -------------------------------------
1414 -- CASE_STATEMENT_ALTERNATIVE ::=
1415 -- when DISCRETE_CHOICE_LIST =>
1416 -- SEQUENCE_OF_STATEMENTS
1418 -- The caller has checked that the initial token is WHEN or OTHERS
1419 -- Error recovery: can raise Error_Resync
1421 function P_Case_Statement_Alternative return Node_Id is
1422 Case_Alt_Node : Node_Id;
1426 Style.Check_Indentation;
1429 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
1430 T_When; -- past WHEN (or give error in OTHERS case)
1431 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
1433 Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
1434 return Case_Alt_Node;
1435 end P_Case_Statement_Alternative;
1437 -------------------------
1438 -- 5.5 Loop Statement --
1439 -------------------------
1441 -- LOOP_STATEMENT ::=
1442 -- [LOOP_STATEMENT_IDENTIFIER:]
1443 -- [ITERATION_SCHEME] loop
1444 -- SEQUENCE_OF_STATEMENTS
1445 -- end loop [loop_IDENTIFIER];
1447 -- ITERATION_SCHEME ::=
1449 -- | for LOOP_PARAMETER_SPECIFICATION
1451 -- The parsing of loop statements is handled by one of three functions
1452 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1453 -- on the initial keyword in the construct (excluding the identifier)
1457 -- This function parses the case where no iteration scheme is present
1459 -- The caller has checked that the initial token is LOOP. The parameter
1460 -- is the node identifiers for the loop label if any (or is set to Empty
1461 -- if there is no loop label).
1463 -- Error recovery : cannot raise Error_Resync
1465 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1466 Loop_Node : Node_Id;
1467 Created_Name : Node_Id;
1471 Scope.Table (Scope.Last).Labl := Loop_Name;
1472 Scope.Table (Scope.Last).Ecol := Start_Column;
1473 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1474 Scope.Table (Scope.Last).Etyp := E_Loop;
1476 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1479 if No (Loop_Name) then
1481 Make_Identifier (Sloc (Loop_Node),
1482 Chars => Set_Loop_Block_Name ('L'));
1483 Set_Comes_From_Source (Created_Name, False);
1484 Set_Has_Created_Identifier (Loop_Node, True);
1485 Set_Identifier (Loop_Node, Created_Name);
1486 Scope.Table (Scope.Last).Labl := Created_Name;
1488 Set_Identifier (Loop_Node, Loop_Name);
1491 Append_Elmt (Loop_Node, Label_List);
1492 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1493 End_Statements (Loop_Node);
1495 end P_Loop_Statement;
1499 -- This function parses a loop statement with a FOR iteration scheme
1501 -- The caller has checked that the initial token is FOR. The parameter
1502 -- is the node identifier for the block label if any (or is set to Empty
1503 -- if there is no block label).
1505 -- Note: the caller fills in the Identifier field if a label was present
1507 -- Error recovery: can raise Error_Resync
1509 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1510 Loop_Node : Node_Id;
1511 Iter_Scheme_Node : Node_Id;
1512 Loop_For_Flag : Boolean;
1513 Created_Name : Node_Id;
1517 Scope.Table (Scope.Last).Labl := Loop_Name;
1518 Scope.Table (Scope.Last).Ecol := Start_Column;
1519 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1520 Scope.Table (Scope.Last).Etyp := E_Loop;
1522 Loop_For_Flag := (Prev_Token = Tok_Loop);
1524 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1525 Set_Loop_Parameter_Specification
1526 (Iter_Scheme_Node, P_Loop_Parameter_Specification);
1528 -- The following is a special test so that a miswritten for loop such
1529 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1530 -- entry in the scope stack. We don't bother to actually fix up the
1531 -- tree in this case since it's not worth the effort. Instead we just
1532 -- eat up the loop junk, leaving the entry for what now looks like an
1533 -- unmodified loop intact.
1535 if Loop_For_Flag and then Token = Tok_Semicolon then
1536 Error_Msg_SC ("LOOP belongs here, not before FOR");
1543 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1545 if No (Loop_Name) then
1547 Make_Identifier (Sloc (Loop_Node),
1548 Chars => Set_Loop_Block_Name ('L'));
1549 Set_Comes_From_Source (Created_Name, False);
1550 Set_Has_Created_Identifier (Loop_Node, True);
1551 Set_Identifier (Loop_Node, Created_Name);
1552 Scope.Table (Scope.Last).Labl := Created_Name;
1554 Set_Identifier (Loop_Node, Loop_Name);
1558 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1559 End_Statements (Loop_Node);
1560 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1561 Append_Elmt (Loop_Node, Label_List);
1564 end P_For_Statement;
1566 -- P_While_Statement
1568 -- This procedure scans a loop statement with a WHILE iteration scheme
1570 -- The caller has checked that the initial token is WHILE. The parameter
1571 -- is the node identifier for the block label if any (or is set to Empty
1572 -- if there is no block label).
1574 -- Error recovery: cannot raise Error_Resync
1576 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1577 Loop_Node : Node_Id;
1578 Iter_Scheme_Node : Node_Id;
1579 Loop_While_Flag : Boolean;
1580 Created_Name : Node_Id;
1584 Scope.Table (Scope.Last).Labl := Loop_Name;
1585 Scope.Table (Scope.Last).Ecol := Start_Column;
1586 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1587 Scope.Table (Scope.Last).Etyp := E_Loop;
1589 Loop_While_Flag := (Prev_Token = Tok_Loop);
1590 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1592 Set_Condition (Iter_Scheme_Node, P_Condition);
1594 -- The following is a special test so that a miswritten for loop such
1595 -- as "loop while I > 10;" is handled nicely, without making an extra
1596 -- entry in the scope stack. We don't bother to actually fix up the
1597 -- tree in this case since it's not worth the effort. Instead we just
1598 -- eat up the loop junk, leaving the entry for what now looks like an
1599 -- unmodified loop intact.
1601 if Loop_While_Flag and then Token = Tok_Semicolon then
1602 Error_Msg_SC ("LOOP belongs here, not before WHILE");
1609 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1612 if No (Loop_Name) then
1614 Make_Identifier (Sloc (Loop_Node),
1615 Chars => Set_Loop_Block_Name ('L'));
1616 Set_Comes_From_Source (Created_Name, False);
1617 Set_Has_Created_Identifier (Loop_Node, True);
1618 Set_Identifier (Loop_Node, Created_Name);
1619 Scope.Table (Scope.Last).Labl := Created_Name;
1621 Set_Identifier (Loop_Node, Loop_Name);
1624 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1625 End_Statements (Loop_Node);
1626 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1627 Append_Elmt (Loop_Node, Label_List);
1630 end P_While_Statement;
1632 ---------------------------------------
1633 -- 5.5 Loop Parameter Specification --
1634 ---------------------------------------
1636 -- LOOP_PARAMETER_SPECIFICATION ::=
1637 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1639 -- Error recovery: cannot raise Error_Resync
1641 function P_Loop_Parameter_Specification return Node_Id is
1642 Loop_Param_Specification_Node : Node_Id;
1645 Scan_State : Saved_Scan_State;
1648 Loop_Param_Specification_Node :=
1649 New_Node (N_Loop_Parameter_Specification, Token_Ptr);
1651 Save_Scan_State (Scan_State);
1652 ID_Node := P_Defining_Identifier (C_In);
1653 Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
1655 if Token = Tok_Left_Paren then
1656 Error_Msg_SC ("subscripted loop parameter not allowed");
1657 Restore_Scan_State (Scan_State);
1658 Discard_Junk_Node (P_Name);
1660 elsif Token = Tok_Dot then
1661 Error_Msg_SC ("selected loop parameter not allowed");
1662 Restore_Scan_State (Scan_State);
1663 Discard_Junk_Node (P_Name);
1668 if Token = Tok_Reverse then
1669 Scan; -- past REVERSE
1670 Set_Reverse_Present (Loop_Param_Specification_Node, True);
1673 Set_Discrete_Subtype_Definition
1674 (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
1675 return Loop_Param_Specification_Node;
1678 when Error_Resync =>
1680 end P_Loop_Parameter_Specification;
1682 --------------------------
1683 -- 5.6 Block Statement --
1684 --------------------------
1686 -- BLOCK_STATEMENT ::=
1687 -- [block_STATEMENT_IDENTIFIER:]
1689 -- DECLARATIVE_PART]
1691 -- HANDLED_SEQUENCE_OF_STATEMENTS
1692 -- end [block_IDENTIFIER];
1694 -- The parsing of block statements is handled by one of the two functions
1695 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1696 -- a declare section is present
1698 -- P_Declare_Statement
1700 -- This function parses a block statement with DECLARE present
1702 -- The caller has checked that the initial token is DECLARE
1704 -- Error recovery: cannot raise Error_Resync
1706 function P_Declare_Statement
1707 (Block_Name : Node_Id := Empty)
1710 Block_Node : Node_Id;
1711 Created_Name : Node_Id;
1714 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1717 Scope.Table (Scope.Last).Etyp := E_Name;
1718 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1719 Scope.Table (Scope.Last).Ecol := Start_Column;
1720 Scope.Table (Scope.Last).Labl := Block_Name;
1721 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1723 Scan; -- past DECLARE
1725 if No (Block_Name) then
1727 Make_Identifier (Sloc (Block_Node),
1728 Chars => Set_Loop_Block_Name ('B'));
1729 Set_Comes_From_Source (Created_Name, False);
1730 Set_Has_Created_Identifier (Block_Node, True);
1731 Set_Identifier (Block_Node, Created_Name);
1732 Scope.Table (Scope.Last).Labl := Created_Name;
1734 Set_Identifier (Block_Node, Block_Name);
1737 Append_Elmt (Block_Node, Label_List);
1738 Parse_Decls_Begin_End (Block_Node);
1740 end P_Declare_Statement;
1742 -- P_Begin_Statement
1744 -- This function parses a block statement with no DECLARE present
1746 -- The caller has checked that the initial token is BEGIN
1748 -- Error recovery: cannot raise Error_Resync
1750 function P_Begin_Statement
1751 (Block_Name : Node_Id := Empty)
1754 Block_Node : Node_Id;
1755 Created_Name : Node_Id;
1758 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1761 Scope.Table (Scope.Last).Etyp := E_Name;
1762 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1763 Scope.Table (Scope.Last).Ecol := Start_Column;
1764 Scope.Table (Scope.Last).Labl := Block_Name;
1765 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1767 if No (Block_Name) then
1769 Make_Identifier (Sloc (Block_Node),
1770 Chars => Set_Loop_Block_Name ('B'));
1771 Set_Comes_From_Source (Created_Name, False);
1772 Set_Has_Created_Identifier (Block_Node, True);
1773 Set_Identifier (Block_Node, Created_Name);
1774 Scope.Table (Scope.Last).Labl := Created_Name;
1776 Set_Identifier (Block_Node, Block_Name);
1779 Append_Elmt (Block_Node, Label_List);
1781 Scope.Table (Scope.Last).Ecol := Start_Column;
1782 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1784 Set_Handled_Statement_Sequence
1785 (Block_Node, P_Handled_Sequence_Of_Statements);
1786 End_Statements (Handled_Statement_Sequence (Block_Node));
1788 end P_Begin_Statement;
1790 -------------------------
1791 -- 5.7 Exit Statement --
1792 -------------------------
1794 -- EXIT_STATEMENT ::=
1795 -- exit [loop_NAME] [when CONDITION];
1797 -- The caller has checked that the initial token is EXIT
1799 -- Error recovery: can raise Error_Resync
1801 function P_Exit_Statement return Node_Id is
1802 Exit_Node : Node_Id;
1804 function Missing_Semicolon_On_Exit return Boolean;
1805 -- This function deals with the following specialized situation
1808 -- exit [identifier]
1811 -- This looks like a messed up EXIT WHEN, when in fact the problem
1812 -- is a missing semicolon. It is called with Token pointing to the
1813 -- WHEN token, and returns True if a semicolon is missing before
1814 -- the WHEN as in the above example.
1816 -------------------------------
1817 -- Missing_Semicolon_On_Exit --
1818 -------------------------------
1820 function Missing_Semicolon_On_Exit return Boolean is
1821 State : Saved_Scan_State;
1824 if not Token_Is_At_Start_Of_Line then
1827 elsif Scope.Table (Scope.Last).Etyp /= E_Case then
1831 Save_Scan_State (State);
1833 Scan; -- past token after WHEN
1835 if Token = Tok_Arrow then
1836 Restore_Scan_State (State);
1839 Restore_Scan_State (State);
1843 end Missing_Semicolon_On_Exit;
1845 -- Start of processing for P_Exit_Statement
1848 Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
1851 if Token = Tok_Identifier then
1852 Set_Name (Exit_Node, P_Qualified_Simple_Name);
1854 elsif Style_Check then
1855 -- This EXIT has no name, so check that
1856 -- the innermost loop is unnamed too.
1858 Check_No_Exit_Name :
1859 for J in reverse 1 .. Scope.Last loop
1860 if Scope.Table (J).Etyp = E_Loop then
1861 if Present (Scope.Table (J).Labl)
1862 and then Comes_From_Source (Scope.Table (J).Labl)
1864 -- Innermost loop in fact had a name, style check fails
1866 Style.No_Exit_Name (Scope.Table (J).Labl);
1869 exit Check_No_Exit_Name;
1871 end loop Check_No_Exit_Name;
1874 if Token = Tok_When and then not Missing_Semicolon_On_Exit then
1876 Set_Condition (Exit_Node, P_Condition);
1878 -- Allow IF instead of WHEN, giving error message
1880 elsif Token = Tok_If then
1882 Scan; -- past IF used in place of WHEN
1883 Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
1888 end P_Exit_Statement;
1890 -------------------------
1891 -- 5.8 Goto Statement --
1892 -------------------------
1894 -- GOTO_STATEMENT ::= goto label_NAME;
1896 -- The caller has checked that the initial token is GOTO (or TO in the
1897 -- error case where GO and TO were incorrectly separated).
1899 -- Error recovery: can raise Error_Resync
1901 function P_Goto_Statement return Node_Id is
1902 Goto_Node : Node_Id;
1905 Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
1906 Scan; -- past GOTO (or TO)
1907 Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
1908 Append_Elmt (Goto_Node, Goto_List);
1912 end P_Goto_Statement;
1914 ---------------------------
1915 -- Parse_Decls_Begin_End --
1916 ---------------------------
1918 -- This function parses the construct:
1922 -- HANDLED_SEQUENCE_OF_STATEMENTS
1925 -- The caller has built the scope stack entry, and created the node to
1926 -- whose Declarations and Handled_Statement_Sequence fields are to be
1927 -- set. On return these fields are filled in (except in the case of a
1928 -- task body, where the handled statement sequence is optional, and may
1929 -- thus be Empty), and the scan is positioned past the End sequence.
1931 -- If the BEGIN is missing, then the parent node is used to help construct
1932 -- an appropriate missing BEGIN message. Possibilities for the parent are:
1934 -- N_Block_Statement declare block
1935 -- N_Entry_Body entry body
1936 -- N_Package_Body package body (begin part optional)
1937 -- N_Subprogram_Body procedure or function body
1938 -- N_Task_Body task body
1940 -- Note: in the case of a block statement, there is definitely a DECLARE
1941 -- present (because a Begin statement without a DECLARE is handled by the
1942 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
1944 -- Error recovery: cannot raise Error_Resync
1946 procedure Parse_Decls_Begin_End (Parent : Node_Id) is
1947 Body_Decl : Node_Id;
1948 Body_Sloc : Source_Ptr;
1951 Parent_Nkind : Node_Kind;
1952 Spec_Node : Node_Id;
1955 procedure Missing_Begin (Msg : String);
1956 -- Called to post a missing begin message. In the normal case this is
1957 -- posted at the start of the current token. A special case arises when
1958 -- P_Declarative_Items has previously found a missing begin, in which
1959 -- case we replace the original error message.
1961 procedure Set_Null_HSS (Parent : Node_Id);
1962 -- Construct an empty handled statement sequence and install in Parent
1963 -- Leaves HSS set to reference the newly constructed statement sequence.
1969 procedure Missing_Begin (Msg : String) is
1971 if Missing_Begin_Msg = No_Error_Msg then
1974 Change_Error_Text (Missing_Begin_Msg, Msg);
1976 -- Purge any messages issued after than, since a missing begin
1977 -- can cause a lot of havoc, and it is better not to dump these
1978 -- cascaded messages on the user.
1980 Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
1988 procedure Set_Null_HSS (Parent : Node_Id) is
1993 Make_Null_Statement (Token_Ptr);
1994 Set_Comes_From_Source (Null_Stm, False);
1997 Make_Handled_Sequence_Of_Statements (Token_Ptr,
1998 Statements => New_List (Null_Stm));
1999 Set_Comes_From_Source (HSS, False);
2001 Set_Handled_Statement_Sequence (Parent, HSS);
2004 -- Start of processing for Parse_Decls_Begin_End
2007 Decls := P_Declarative_Part;
2009 -- Check for misplacement of later vs basic declarations in Ada 83
2011 if Ada_Version = Ada_83 then
2012 Decl := First (Decls);
2014 -- Loop through sequence of basic declarative items
2016 Outer : while Present (Decl) loop
2017 if Nkind (Decl) /= N_Subprogram_Body
2018 and then Nkind (Decl) /= N_Package_Body
2019 and then Nkind (Decl) /= N_Task_Body
2020 and then Nkind (Decl) not in N_Body_Stub
2024 -- Once a body is encountered, we only allow later declarative
2025 -- items. The inner loop checks the rest of the list.
2028 Body_Sloc := Sloc (Decl);
2030 Inner : while Present (Decl) loop
2031 if Nkind (Decl) not in N_Later_Decl_Item
2032 and then Nkind (Decl) /= N_Pragma
2034 if Ada_Version = Ada_83 then
2035 Error_Msg_Sloc := Body_Sloc;
2037 ("(Ada 83) decl cannot appear after body#", Decl);
2047 -- Here is where we deal with the case of IS used instead of semicolon.
2048 -- Specifically, if the last declaration in the declarative part is a
2049 -- subprogram body still marked as having a bad IS, then this is where
2050 -- we decide that the IS should really have been a semicolon and that
2051 -- the body should have been a declaration. Note that if the bad IS
2052 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2053 -- then the Bad_Is_Detected flag would have been reset by now.
2055 Body_Decl := Last (Decls);
2057 if Present (Body_Decl)
2058 and then Nkind (Body_Decl) = N_Subprogram_Body
2059 and then Bad_Is_Detected (Body_Decl)
2061 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2062 -- What we have now is a subprogram body with attached declarations
2063 -- and a possible statement sequence.
2065 -- First step is to take the declarations that were part of the bogus
2066 -- subprogram body and append them to the outer declaration chain.
2067 -- In other words we append them past the body (which we will later
2068 -- convert into a declaration).
2070 Append_List (Declarations (Body_Decl), Decls);
2072 -- Now take the handled statement sequence of the bogus body and
2073 -- set it as the statement sequence for the outer construct. Note
2074 -- that it may be empty (we specially allowed a missing BEGIN for
2075 -- a subprogram body marked as having a bad IS -- see below).
2077 Set_Handled_Statement_Sequence (Parent,
2078 Handled_Statement_Sequence (Body_Decl));
2080 -- Next step is to convert the old body node to a declaration node
2082 Spec_Node := Specification (Body_Decl);
2083 Change_Node (Body_Decl, N_Subprogram_Declaration);
2084 Set_Specification (Body_Decl, Spec_Node);
2086 -- Final step is to put the declarations for the parent where
2087 -- they belong, and then fall through the IF to scan out the
2090 Set_Declarations (Parent, Decls);
2092 -- This is the normal case (i.e. any case except the bad IS case)
2093 -- If we have a BEGIN, then scan out the sequence of statements, and
2094 -- also reset the expected column for the END to match the BEGIN.
2097 Set_Declarations (Parent, Decls);
2099 if Token = Tok_Begin then
2101 Style.Check_Indentation;
2104 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
2107 and then Token_Is_At_Start_Of_Line
2108 and then Start_Column /= Error_Msg_Col
2110 Error_Msg_SC ("(style) BEGIN in wrong column, should be@");
2113 Scope.Table (Scope.Last).Ecol := Start_Column;
2116 Scope.Table (Scope.Last).Sloc := Token_Ptr;
2118 Set_Handled_Statement_Sequence (Parent,
2119 P_Handled_Sequence_Of_Statements);
2124 Parent_Nkind := Nkind (Parent);
2126 -- A special check for the missing IS case. If we have a
2127 -- subprogram body that was marked as having a suspicious
2128 -- IS, and the current token is END, then we simply confirm
2129 -- the suspicion, and do not require a BEGIN to be present
2131 if Parent_Nkind = N_Subprogram_Body
2132 and then Token = Tok_End
2133 and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is
2135 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
2137 -- Otherwise BEGIN is not required for a package body, so we
2138 -- don't mind if it is missing, but we do construct a dummy
2139 -- one (so that we have somewhere to set End_Label).
2141 -- However if we have something other than a BEGIN which
2142 -- looks like it might be statements, then we signal a missing
2143 -- BEGIN for these cases as well. We define "something which
2144 -- looks like it might be statements" as a token other than
2145 -- END, EOF, or a token which starts declarations.
2147 elsif Parent_Nkind = N_Package_Body
2148 and then (Token = Tok_End
2149 or else Token = Tok_EOF
2150 or else Token in Token_Class_Declk)
2152 Set_Null_HSS (Parent);
2154 -- These are cases in which a BEGIN is required and not present
2157 Set_Null_HSS (Parent);
2159 -- Prepare to issue error message
2161 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
2162 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
2164 -- Now issue appropriate message
2166 if Parent_Nkind = N_Block_Statement then
2167 Missing_Begin ("missing BEGIN for DECLARE#!");
2169 elsif Parent_Nkind = N_Entry_Body then
2170 Missing_Begin ("missing BEGIN for ENTRY#!");
2172 elsif Parent_Nkind = N_Subprogram_Body then
2173 if Nkind (Specification (Parent))
2174 = N_Function_Specification
2176 Missing_Begin ("missing BEGIN for function&#!");
2178 Missing_Begin ("missing BEGIN for procedure&#!");
2181 -- The case for package body arises only when
2182 -- we have possible statement junk present.
2184 elsif Parent_Nkind = N_Package_Body then
2185 Missing_Begin ("missing BEGIN for package body&#!");
2188 pragma Assert (Parent_Nkind = N_Task_Body);
2189 Missing_Begin ("missing BEGIN for task body&#!");
2192 -- Here we pick up the statements after the BEGIN that
2193 -- should have been present but was not. We don't insist
2194 -- on statements being present if P_Declarative_Part had
2195 -- already found a missing BEGIN, since it might have
2196 -- swallowed a lone statement into the declarative part.
2198 if Missing_Begin_Msg /= No_Error_Msg
2199 and then Token = Tok_End
2203 Set_Handled_Statement_Sequence (Parent,
2204 P_Handled_Sequence_Of_Statements);
2210 -- Here with declarations and handled statement sequence scanned
2212 if Present (Handled_Statement_Sequence (Parent)) then
2213 End_Statements (Handled_Statement_Sequence (Parent));
2218 -- We know that End_Statements removed an entry from the scope stack
2219 -- (because it is required to do so under all circumstances). We can
2220 -- therefore reference the entry it removed one past the stack top.
2221 -- What we are interested in is whether it was a case of a bad IS.
2223 if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
2224 Error_Msg -- CODEFIX
2225 ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
2226 Set_Bad_Is_Detected (Parent, True);
2229 end Parse_Decls_Begin_End;
2231 -------------------------
2232 -- Set_Loop_Block_Name --
2233 -------------------------
2235 function Set_Loop_Block_Name (L : Character) return Name_Id is
2237 Name_Buffer (1) := L;
2238 Name_Buffer (2) := '_';
2240 Loop_Block_Count := Loop_Block_Count + 1;
2241 Add_Nat_To_Name_Buffer (Loop_Block_Count);
2243 end Set_Loop_Block_Name;
2249 procedure Then_Scan is
2253 while Token = Tok_Then loop
2254 Error_Msg_SC -- CODEFIX
2259 if Token = Tok_And or else Token = Tok_Or then
2260 Error_Msg_SC ("unexpected logical operator");
2261 Scan; -- past logical operator
2263 if (Prev_Token = Tok_And and then Token = Tok_Then)
2265 (Prev_Token = Tok_Or and then Token = Tok_Else)
2270 Discard_Junk_Node (P_Expression);
2273 if Token = Tok_Then then