1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 pragma Style_Checks (All_Checks);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical
34 -- Local functions, used only in this chapter
36 function P_Case_Statement return Node_Id;
37 function P_Case_Statement_Alternative return Node_Id;
38 function P_Condition return Node_Id;
39 function P_Exit_Statement return Node_Id;
40 function P_Goto_Statement return Node_Id;
41 function P_If_Statement return Node_Id;
42 function P_Label return Node_Id;
43 function P_Loop_Parameter_Specification return Node_Id;
44 function P_Null_Statement return Node_Id;
46 function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
47 -- Parse assignment statement. On entry, the caller has scanned the left
48 -- hand side (passed in as Lhs), and the colon-equal (or some symbol
49 -- taken to be an error equivalent such as equal).
51 function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id;
52 -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is
53 -- the N_Identifier node for the label on the block. If Block_Name is
54 -- Empty on entry (the default), then the block statement is unlabeled.
56 function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id;
57 -- Parse declare block. If Block_Name is non-Empty on entry, it is
58 -- the N_Identifier node for the label on the block. If Block_Name is
59 -- Empty on entry (the default), then the block statement is unlabeled.
61 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
62 -- Parse for statement. If Loop_Name is non-Empty on entry, it is
63 -- the N_Identifier node for the label on the loop. If Loop_Name is
64 -- Empty on entry (the default), then the for statement is unlabeled.
66 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
67 -- Parse loop statement. If Loop_Name is non-Empty on entry, it is
68 -- the N_Identifier node for the label on the loop. If Loop_Name is
69 -- Empty on entry (the default), then the loop statement is unlabeled.
71 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
72 -- Parse while statement. If Loop_Name is non-Empty on entry, it is
73 -- the N_Identifier node for the label on the loop. If Loop_Name is
74 -- Empty on entry (the default), then the while statement is unlabeled.
76 function Set_Loop_Block_Name (L : Character) return Name_Id;
77 -- Given a letter 'L' for a loop or 'B' for a block, returns a name
78 -- of the form L_nn or B_nn where nn is a serial number obtained by
79 -- incrementing the variable Loop_Block_Count.
82 -- Scan past THEN token, testing for illegal junk after it
84 ---------------------------------
85 -- 5.1 Sequence of Statements --
86 ---------------------------------
88 -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT}
91 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
93 -- SIMPLE_STATEMENT ::= NULL_STATEMENT
94 -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT
95 -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT
96 -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT
97 -- | REQUEUE_STATEMENT | DELAY_STATEMENT
98 -- | ABORT_STATEMENT | RAISE_STATEMENT
101 -- COMPOUND_STATEMENT ::=
102 -- IF_STATEMENT | CASE_STATEMENT
103 -- | LOOP_STATEMENT | BLOCK_STATEMENT
104 -- | ACCEPT_STATEMENT | SELECT_STATEMENT
106 -- This procedure scans a sequence of statements. The caller sets SS_Flags
107 -- to indicate acceptable termination conditions for the sequence:
109 -- SS_Flags.Eftm Terminate on ELSIF
110 -- SS_Flags.Eltm Terminate on ELSE
111 -- SS_Flags.Extm Terminate on EXCEPTION
112 -- SS_Flags.Ortm Terminate on OR
113 -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return)
114 -- SS_Flags.Whtm Terminate on WHEN
115 -- SS_Flags.Unco Unconditional terminate after scanning one statement
117 -- In addition, the scan is always terminated by encountering END or the
118 -- end of file (EOF) condition. If one of the six above terminators is
119 -- encountered with the corresponding SS_Flags flag not set, then the
120 -- action taken is as follows:
122 -- If the keyword occurs to the left of the expected column of the end
123 -- for the current sequence (as recorded in the current end context),
124 -- then it is assumed to belong to an outer context, and is considered
125 -- to terminate the sequence of statements.
127 -- If the keyword occurs to the right of, or in the expected column of
128 -- the end for the current sequence, then an error message is output,
129 -- the keyword together with its associated context is skipped, and
130 -- the statement scan continues until another terminator is found.
132 -- Note that the first action means that control can return to the caller
133 -- with Token set to a terminator other than one of those specified by the
134 -- SS parameter. The caller should treat such a case as equivalent to END.
136 -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at
137 -- least one real statement (other than a pragma) is required in the
138 -- statement sequence. During the processing of the sequence, this
139 -- flag is manipulated to indicate the current status of the requirement
140 -- for a statement. For example, it is turned off by the occurrence of a
141 -- statement, and back on by a label (which requires a following statement)
143 -- Error recovery: cannot raise Error_Resync. If an error occurs during
144 -- parsing a statement, then the scan pointer is advanced past the next
145 -- semicolon and the parse continues.
147 function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is
149 Statement_Required : Boolean;
150 -- This flag indicates if a subsequent statement (other than a pragma)
151 -- is required. It is initialized from the Sreq flag, and modified as
152 -- statements are scanned (a statement turns it off, and a label turns
153 -- it back on again since a statement must follow a label).
155 Declaration_Found : Boolean := False;
156 -- This flag is set True if a declaration is encountered, so that the
157 -- error message about declarations in the statement part is only
158 -- given once for a given sequence of statements.
160 Scan_State_Label : Saved_Scan_State;
161 Scan_State : Saved_Scan_State;
163 Statement_List : List_Id;
164 Block_Label : Name_Id;
168 procedure Junk_Declaration;
169 -- Procedure called to handle error of declaration encountered in
170 -- statement sequence.
172 procedure Test_Statement_Required;
173 -- Flag error if Statement_Required flag set
175 ----------------------
176 -- Junk_Declaration --
177 ----------------------
179 procedure Junk_Declaration is
181 if (not Declaration_Found) or All_Errors_Mode then
182 Error_Msg_SC ("declarations must come before BEGIN");
183 Declaration_Found := True;
186 Skip_Declaration (Statement_List);
187 end Junk_Declaration;
189 -----------------------------
190 -- Test_Statement_Required --
191 -----------------------------
193 procedure Test_Statement_Required is
195 if Statement_Required then
196 Error_Msg_BC ("statement expected");
198 end Test_Statement_Required;
200 -- Start of processing for P_Sequence_Of_Statements
203 Statement_List := New_List;
204 Statement_Required := SS_Flags.Sreq;
207 while Token = Tok_Semicolon loop
208 Error_Msg_SC ("unexpected semicolon ignored");
209 Scan; -- past junk semicolon
214 Style.Check_Indentation;
217 -- Deal with reserved identifier (in assignment or call)
219 if Is_Reserved_Identifier then
220 Save_Scan_State (Scan_State); -- at possible bad identifier
221 Scan; -- and scan past it
223 -- We have an reserved word which is spelled in identifier
224 -- style, so the question is whether it really is intended
225 -- to be an identifier.
228 -- If followed by a semicolon, then it is an identifier,
229 -- with the exception of the cases tested for below.
231 (Token = Tok_Semicolon
232 and then Prev_Token /= Tok_Return
233 and then Prev_Token /= Tok_Null
234 and then Prev_Token /= Tok_Raise
235 and then Prev_Token /= Tok_End
236 and then Prev_Token /= Tok_Exit)
238 -- If followed by colon, colon-equal, or dot, then we
239 -- definitely have an identifier (could not be reserved)
241 or else Token = Tok_Colon
242 or else Token = Tok_Colon_Equal
243 or else Token = Tok_Dot
245 -- Left paren means we have an identifier except for those
246 -- reserved words that can legitimately be followed by a
250 (Token = Tok_Left_Paren
251 and then Prev_Token /= Tok_Case
252 and then Prev_Token /= Tok_Delay
253 and then Prev_Token /= Tok_If
254 and then Prev_Token /= Tok_Elsif
255 and then Prev_Token /= Tok_Return
256 and then Prev_Token /= Tok_When
257 and then Prev_Token /= Tok_While
258 and then Prev_Token /= Tok_Separate)
260 -- Here we have an apparent reserved identifier and the
261 -- token past it is appropriate to this usage (and would
262 -- be a definite error if this is not an identifier). What
263 -- we do is to use P_Identifier to fix up the identifier,
264 -- and then fall into the normal processing.
266 Restore_Scan_State (Scan_State); -- back to the ID
267 Scan_Reserved_Identifier (Force_Msg => False);
269 -- Not a reserved identifier after all (or at least we can't
270 -- be sure that it is), so reset the scan and continue.
273 Restore_Scan_State (Scan_State); -- back to the reserved word
277 -- Now look to see what kind of statement we have
281 -- Case of end or EOF
283 when Tok_End | Tok_EOF =>
285 -- These tokens always terminate the statement sequence
287 Test_Statement_Required;
294 -- Terminate if Eftm set or if the ELSIF is to the left
295 -- of the expected column of the end for this sequence
298 or else Start_Column < Scope.Table (Scope.Last).Ecol
300 Test_Statement_Required;
303 -- Otherwise complain and skip past ELSIF Condition then
306 Error_Msg_SC ("ELSIF not allowed here");
308 Discard_Junk_Node (P_Expression_No_Right_Paren);
310 Statement_Required := False;
317 -- Terminate if Eltm set or if the else is to the left
318 -- of the expected column of the end for this sequence
321 or else Start_Column < Scope.Table (Scope.Last).Ecol
323 Test_Statement_Required;
326 -- Otherwise complain and skip past else
329 Error_Msg_SC ("ELSE not allowed here");
331 Statement_Required := False;
336 when Tok_Exception =>
337 Test_Statement_Required;
339 -- If Extm not set and the exception is not to the left
340 -- of the expected column of the end for this sequence, then
341 -- we assume it belongs to the current sequence, even though
342 -- it is not permitted.
344 if not SS_Flags.Extm and then
345 Start_Column >= Scope.Table (Scope.Last).Ecol
348 Error_Msg_SC ("exception handler not permitted here");
349 Scan; -- past EXCEPTION
350 Discard_Junk_List (Parse_Exception_Handlers);
353 -- Always return, in the case where we scanned out handlers
354 -- that we did not expect, Parse_Exception_Handlers returned
355 -- with Token being either end or EOF, so we are OK
363 -- Terminate if Ortm set or if the or is to the left
364 -- of the expected column of the end for this sequence
367 or else Start_Column < Scope.Table (Scope.Last).Ecol
369 Test_Statement_Required;
372 -- Otherwise complain and skip past or
375 Error_Msg_SC ("OR not allowed here");
377 Statement_Required := False;
380 -- Case of THEN (deal also with THEN ABORT)
383 Save_Scan_State (Scan_State); -- at THEN
386 -- Terminate if THEN ABORT allowed (ATC case)
388 exit when SS_Flags.Tatm and then Token = Tok_Abort;
390 -- Otherwise we treat THEN as some kind of mess where we
391 -- did not see the associated IF, but we pick up assuming
392 -- it had been there!
394 Restore_Scan_State (Scan_State); -- to THEN
395 Append_To (Statement_List, P_If_Statement);
396 Statement_Required := False;
398 -- Case of WHEN (error because we are not in a case)
400 when Tok_When | Tok_Others =>
402 -- Terminate if Whtm set or if the WHEN is to the left
403 -- of the expected column of the end for this sequence
406 or else Start_Column < Scope.Table (Scope.Last).Ecol
408 Test_Statement_Required;
411 -- Otherwise complain and skip when Choice {| Choice} =>
414 Error_Msg_SC ("WHEN not allowed here");
416 Discard_Junk_List (P_Discrete_Choice_List);
418 Statement_Required := False;
421 -- Cases of statements starting with an identifier
423 when Tok_Identifier =>
426 -- Save scan pointers and line number in case block label
428 Id_Node := Token_Node;
429 Block_Label := Token_Name;
430 Save_Scan_State (Scan_State_Label); -- at possible label
433 -- Check for common case of assignment, since it occurs
434 -- frequently, and we want to process it efficiently.
436 if Token = Tok_Colon_Equal then
437 Scan; -- past the colon-equal
438 Append_To (Statement_List,
439 P_Assignment_Statement (Id_Node));
440 Statement_Required := False;
442 -- Check common case of procedure call, another case that
443 -- we want to speed up as much as possible.
445 elsif Token = Tok_Semicolon then
446 Append_To (Statement_List,
447 P_Statement_Name (Id_Node));
448 Scan; -- past semicolon
449 Statement_Required := False;
451 -- Check for case of "go to" in place of "goto"
453 elsif Token = Tok_Identifier
454 and then Block_Label = Name_Go
455 and then Token_Name = Name_To
457 Error_Msg_SP ("goto is one word");
458 Append_To (Statement_List, P_Goto_Statement);
459 Statement_Required := False;
461 -- Check common case of = used instead of :=, just so we
462 -- give a better error message for this special misuse.
464 elsif Token = Tok_Equal then
465 T_Colon_Equal; -- give := expected message
466 Append_To (Statement_List,
467 P_Assignment_Statement (Id_Node));
468 Statement_Required := False;
470 -- Check case of loop label or block label
472 elsif Token = Tok_Colon
473 or else (Token in Token_Class_Labeled_Stmt
474 and then not Token_Is_At_Start_Of_Line)
476 T_Colon; -- past colon (if there, or msg for missing one)
478 -- Test for more than one label
481 exit when Token /= Tok_Identifier;
482 Save_Scan_State (Scan_State); -- at second Id
485 if Token = Tok_Colon then
487 ("only one label allowed on block or loop");
488 Scan; -- past colon on extra label
490 -- Use the second label as the "real" label
492 Scan_State_Label := Scan_State;
494 -- We will set Error_name as the Block_Label since
495 -- we really don't know which of the labels might
496 -- be used at the end of the loop or block!
498 Block_Label := Error_Name;
500 -- If Id with no colon, then backup to point to the
501 -- Id and we will issue the message below when we try
502 -- to scan out the statement as some other form.
505 Restore_Scan_State (Scan_State); -- to second Id
510 -- Loop_Statement (labeled Loop_Statement)
512 if Token = Tok_Loop then
513 Append_To (Statement_List,
514 P_Loop_Statement (Id_Node));
516 -- While statement (labeled loop statement with WHILE)
518 elsif Token = Tok_While then
519 Append_To (Statement_List,
520 P_While_Statement (Id_Node));
522 -- Declare statement (labeled block statement with
525 elsif Token = Tok_Declare then
526 Append_To (Statement_List,
527 P_Declare_Statement (Id_Node));
529 -- Begin statement (labeled block statement with no
532 elsif Token = Tok_Begin then
533 Append_To (Statement_List,
534 P_Begin_Statement (Id_Node));
536 -- For statement (labeled loop statement with FOR)
538 elsif Token = Tok_For then
539 Append_To (Statement_List,
540 P_For_Statement (Id_Node));
542 -- Improper statement follows label. If we have an
543 -- expression token, then assume the colon was part
544 -- of a misplaced declaration.
546 elsif Token not in Token_Class_Eterm then
547 Restore_Scan_State (Scan_State_Label);
550 -- Otherwise complain we have inappropriate statement
554 ("loop or block statement must follow label");
557 Statement_Required := False;
559 -- Here we have an identifier followed by something
560 -- other than a colon, semicolon or assignment symbol.
561 -- The only valid possibility is a name extension symbol
563 elsif Token in Token_Class_Namext then
564 Restore_Scan_State (Scan_State_Label); -- to Id
567 -- Skip junk right parens in this context
569 while Token = Tok_Right_Paren loop
570 Error_Msg_SC ("extra right paren");
574 -- Check context following call
576 if Token = Tok_Colon_Equal then
577 Scan; -- past colon equal
578 Append_To (Statement_List,
579 P_Assignment_Statement (Name_Node));
580 Statement_Required := False;
582 -- Check common case of = used instead of :=
584 elsif Token = Tok_Equal then
585 T_Colon_Equal; -- give := expected message
586 Append_To (Statement_List,
587 P_Assignment_Statement (Name_Node));
588 Statement_Required := False;
590 -- Check apostrophe cases
592 elsif Token = Tok_Apostrophe then
593 Append_To (Statement_List,
594 P_Code_Statement (Name_Node));
595 Statement_Required := False;
597 -- The only other valid item after a name is ; which
598 -- means that the item we just scanned was a call.
600 elsif Token = Tok_Semicolon then
601 Append_To (Statement_List,
602 P_Statement_Name (Name_Node));
603 Scan; -- past semicolon
604 Statement_Required := False;
606 -- A slash following an identifier or a selected
607 -- component in this situation is most likely a period
608 -- (see location of keys on keyboard).
610 elsif Token = Tok_Slash
611 and then (Nkind (Name_Node) = N_Identifier
613 Nkind (Name_Node) = N_Selected_Component)
615 Error_Msg_SC ("""/"" should be "".""");
616 Statement_Required := False;
619 -- Else we have a missing semicolon
623 Statement_Required := False;
626 -- If junk after identifier, check if identifier is an
627 -- instance of an incorrectly spelled keyword. If so, we
628 -- do nothing. The Bad_Spelling_Of will have reset Token
629 -- to the appropriate keyword, so the next time round the
630 -- loop we will process the modified token. Note that we
631 -- check for ELSIF before ELSE here. That's not accidental.
632 -- We don't want to identify a misspelling of ELSE as
633 -- ELSIF, and in particular we do not want to treat ELSEIF
637 Restore_Scan_State (Scan_State_Label); -- to identifier
639 if Bad_Spelling_Of (Tok_Abort)
640 or else Bad_Spelling_Of (Tok_Accept)
641 or else Bad_Spelling_Of (Tok_Case)
642 or else Bad_Spelling_Of (Tok_Declare)
643 or else Bad_Spelling_Of (Tok_Delay)
644 or else Bad_Spelling_Of (Tok_Elsif)
645 or else Bad_Spelling_Of (Tok_Else)
646 or else Bad_Spelling_Of (Tok_End)
647 or else Bad_Spelling_Of (Tok_Exception)
648 or else Bad_Spelling_Of (Tok_Exit)
649 or else Bad_Spelling_Of (Tok_For)
650 or else Bad_Spelling_Of (Tok_Goto)
651 or else Bad_Spelling_Of (Tok_If)
652 or else Bad_Spelling_Of (Tok_Loop)
653 or else Bad_Spelling_Of (Tok_Or)
654 or else Bad_Spelling_Of (Tok_Pragma)
655 or else Bad_Spelling_Of (Tok_Raise)
656 or else Bad_Spelling_Of (Tok_Requeue)
657 or else Bad_Spelling_Of (Tok_Return)
658 or else Bad_Spelling_Of (Tok_Select)
659 or else Bad_Spelling_Of (Tok_When)
660 or else Bad_Spelling_Of (Tok_While)
664 -- If not a bad spelling, then we really have junk
667 Scan; -- past identifier again
669 -- If next token is first token on line, then we
670 -- consider that we were missing a semicolon after
671 -- the identifier, and process it as a procedure
672 -- call with no parameters.
674 if Token_Is_At_Start_Of_Line then
675 Append_To (Statement_List,
676 P_Statement_Name (Id_Node));
677 T_Semicolon; -- to give error message
678 Statement_Required := False;
680 -- Otherwise we give a missing := message and
681 -- simply abandon the junk that is there now.
684 T_Colon_Equal; -- give := expected message
691 -- Statement starting with operator symbol. This could be
692 -- a call, a name starting an assignment, or a qualified
695 when Tok_Operator_Symbol =>
699 -- An attempt at a range attribute or a qualified expression
700 -- must be illegal here (a code statement cannot possibly
701 -- allow qualification by a function name).
703 if Token = Tok_Apostrophe then
704 Error_Msg_SC ("apostrophe illegal here");
708 -- Scan possible assignment if we have a name
710 if Expr_Form = EF_Name
711 and then Token = Tok_Colon_Equal
713 Scan; -- past colon equal
714 Append_To (Statement_List,
715 P_Assignment_Statement (Name_Node));
717 Append_To (Statement_List,
718 P_Statement_Name (Name_Node));
722 Statement_Required := False;
724 -- Label starting with << which must precede real statement
726 when Tok_Less_Less =>
727 Append_To (Statement_List, P_Label);
728 Statement_Required := True;
730 -- Pragma appearing as a statement in a statement sequence
734 Append_To (Statement_List, P_Pragma);
740 Append_To (Statement_List, P_Abort_Statement);
741 Statement_Required := False;
747 Append_To (Statement_List, P_Accept_Statement);
748 Statement_Required := False;
750 -- Begin_Statement (Block_Statement with no declare, no label)
754 Append_To (Statement_List, P_Begin_Statement);
755 Statement_Required := False;
761 Append_To (Statement_List, P_Case_Statement);
762 Statement_Required := False;
764 -- Block_Statement with DECLARE and no label
768 Append_To (Statement_List, P_Declare_Statement);
769 Statement_Required := False;
775 Append_To (Statement_List, P_Delay_Statement);
776 Statement_Required := False;
782 Append_To (Statement_List, P_Exit_Statement);
783 Statement_Required := False;
785 -- Loop_Statement with FOR and no label
789 Append_To (Statement_List, P_For_Statement);
790 Statement_Required := False;
796 Append_To (Statement_List, P_Goto_Statement);
797 Statement_Required := False;
803 Append_To (Statement_List, P_If_Statement);
804 Statement_Required := False;
810 Append_To (Statement_List, P_Loop_Statement);
811 Statement_Required := False;
817 Append_To (Statement_List, P_Null_Statement);
818 Statement_Required := False;
824 Append_To (Statement_List, P_Raise_Statement);
825 Statement_Required := False;
831 Append_To (Statement_List, P_Requeue_Statement);
832 Statement_Required := False;
838 Append_To (Statement_List, P_Return_Statement);
839 Statement_Required := False;
845 Append_To (Statement_List, P_Select_Statement);
846 Statement_Required := False;
848 -- While_Statement (Block_Statement with while and no loop)
852 Append_To (Statement_List, P_While_Statement);
853 Statement_Required := False;
855 -- Anything else is some kind of junk, signal an error message
856 -- and then raise Error_Resync, to merge with the normal
857 -- handling of a bad statement.
861 if Token in Token_Class_Declk then
865 Error_Msg_BC ("statement expected");
870 -- On error resynchronization, skip past next semicolon, and, since
871 -- we are still in the statement loop, look for next statement. We
872 -- set Statement_Required False to avoid an unnecessary error message
873 -- complaining that no statement was found (i.e. we consider the
874 -- junk to satisfy the requirement for a statement being present).
878 Resync_Past_Semicolon_Or_To_Loop_Or_Then;
879 Statement_Required := False;
882 exit when SS_Flags.Unco;
886 return Statement_List;
888 end P_Sequence_Of_Statements;
894 -- Parsed by P_Sequence_Of_Statements (5.1), except for the case
895 -- of a statement of the form of a name, which is handled here. The
896 -- argument passed in is the tree for the name which has been scanned
897 -- The returned value is the corresponding statement form.
899 -- This routine is also used by Par.Prag for processing the procedure
900 -- call that appears as the second argument of a pragma Assert.
902 -- Error recovery: cannot raise Error_Resync
904 function P_Statement_Name (Name_Node : Node_Id) return Node_Id is
908 -- Case of Indexed component, which is a procedure call with arguments
910 if Nkind (Name_Node) = N_Indexed_Component then
912 Prefix_Node : constant Node_Id := Prefix (Name_Node);
913 Exprs_Node : constant List_Id := Expressions (Name_Node);
916 Change_Node (Name_Node, N_Procedure_Call_Statement);
917 Set_Name (Name_Node, Prefix_Node);
918 Set_Parameter_Associations (Name_Node, Exprs_Node);
922 -- Case of function call node, which is a really a procedure call
924 elsif Nkind (Name_Node) = N_Function_Call then
926 Fname_Node : constant Node_Id := Name (Name_Node);
927 Params_List : constant List_Id :=
928 Parameter_Associations (Name_Node);
931 Change_Node (Name_Node, N_Procedure_Call_Statement);
932 Set_Name (Name_Node, Fname_Node);
933 Set_Parameter_Associations (Name_Node, Params_List);
937 -- Case of call to attribute that denotes a procedure. Here we
938 -- just leave the attribute reference unchanged.
940 elsif Nkind (Name_Node) = N_Attribute_Reference
941 and then Is_Procedure_Attribute_Name (Attribute_Name (Name_Node))
945 -- All other cases of names are parameterless procedure calls
949 New_Node (N_Procedure_Call_Statement, Sloc (Name_Node));
950 Set_Name (Stmt_Node, Name_Node);
954 end P_Statement_Name;
956 ---------------------------
957 -- 5.1 Simple Statement --
958 ---------------------------
960 -- Parsed by P_Sequence_Of_Statements (5.1)
962 -----------------------------
963 -- 5.1 Compound Statement --
964 -----------------------------
966 -- Parsed by P_Sequence_Of_Statements (5.1)
968 -------------------------
969 -- 5.1 Null Statement --
970 -------------------------
972 -- NULL_STATEMENT ::= null;
974 -- The caller has already checked that the current token is null
976 -- Error recovery: cannot raise Error_Resync
978 function P_Null_Statement return Node_Id is
979 Null_Stmt_Node : Node_Id;
982 Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr);
985 return Null_Stmt_Node;
986 end P_Null_Statement;
992 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
994 -- STATEMENT_INDENTIFIER ::= DIRECT_NAME
996 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
997 -- (not an OPERATOR_SYMBOL)
999 -- The caller has already checked that the current token is <<
1001 -- Error recovery: can raise Error_Resync
1003 function P_Label return Node_Id is
1004 Label_Node : Node_Id;
1007 Label_Node := New_Node (N_Label, Token_Ptr);
1009 Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
1011 Append_Elmt (Label_Node, Label_List);
1015 -------------------------------
1016 -- 5.1 Statement Identifier --
1017 -------------------------------
1019 -- Statement label is parsed by P_Label (5.1)
1021 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1022 -- or P_While_Statement (5.5)
1024 -- Block label is parsed by P_Begin_Statement (5.6) or
1025 -- P_Declare_Statement (5.6)
1027 -------------------------------
1028 -- 5.2 Assignment Statement --
1029 -------------------------------
1031 -- ASSIGNMENT_STATEMENT ::=
1032 -- variable_NAME := EXPRESSION;
1034 -- Error recovery: can raise Error_Resync
1036 function P_Assignment_Statement (LHS : Node_Id) return Node_Id is
1037 Assign_Node : Node_Id;
1040 Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr);
1041 Set_Name (Assign_Node, LHS);
1042 Set_Expression (Assign_Node, P_Expression_No_Right_Paren);
1045 end P_Assignment_Statement;
1047 -----------------------
1048 -- 5.3 If Statement --
1049 -----------------------
1052 -- if CONDITION then
1053 -- SEQUENCE_OF_STATEMENTS
1054 -- {elsif CONDITION then
1055 -- SEQUENCE_OF_STATEMENTS}
1057 -- SEQUENCE_OF_STATEMENTS]
1060 -- The caller has checked that the initial token is IF (or in the error
1061 -- case of a mysterious THEN, the initial token may simply be THEN, in
1062 -- which case, no condition (or IF) was scanned).
1064 -- Error recovery: can raise Error_Resync
1066 function P_If_Statement return Node_Id is
1068 Elsif_Node : Node_Id;
1071 procedure Add_Elsif_Part;
1072 -- An internal procedure used to scan out a single ELSIF part. On entry
1073 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1074 -- scanned out and is in Prev_Token.
1076 procedure Check_If_Column;
1077 -- An internal procedure used to check that THEN, ELSE ELSE, or ELSIF
1078 -- appear in the right place if column checking is enabled (i.e. if
1079 -- they are the first token on the line, then they must appear in
1080 -- the same column as the opening IF).
1082 procedure Check_Then_Column;
1083 -- This procedure carries out the style checks for a THEN token
1084 -- Note that the caller has set Loc to the Source_Ptr value for
1085 -- the previous IF or ELSIF token. These checks apply only to a
1086 -- THEN at the start of a line.
1088 function Else_Should_Be_Elsif return Boolean;
1089 -- An internal routine used to do a special error recovery check when
1090 -- an ELSE is encountered. It determines if the ELSE should be treated
1091 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1092 -- is followed by a sequence of tokens, starting on the same line as
1093 -- the ELSE, which are not expression terminators, followed by a THEN.
1094 -- On entry, the ELSE has been scanned out.
1096 procedure Add_Elsif_Part is
1098 if No (Elsif_Parts (If_Node)) then
1099 Set_Elsif_Parts (If_Node, New_List);
1102 Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr);
1103 Loc := Prev_Token_Ptr;
1104 Set_Condition (Elsif_Node, P_Condition);
1108 (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1109 Append (Elsif_Node, Elsif_Parts (If_Node));
1112 procedure Check_If_Column is
1114 if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line
1115 and then Start_Column /= Scope.Table (Scope.Last).Ecol
1117 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
1118 Error_Msg_SC ("(style) this token should be@");
1120 end Check_If_Column;
1122 procedure Check_Then_Column is
1124 if Token_Is_At_Start_Of_Line and then Token = Tok_Then then
1128 Style.Check_Then (Loc);
1131 end Check_Then_Column;
1133 function Else_Should_Be_Elsif return Boolean is
1134 Scan_State : Saved_Scan_State;
1137 if Token_Is_At_Start_Of_Line then
1141 Save_Scan_State (Scan_State);
1144 if Token in Token_Class_Eterm then
1145 Restore_Scan_State (Scan_State);
1148 Scan; -- past non-expression terminating token
1150 if Token = Tok_Then then
1151 Restore_Scan_State (Scan_State);
1157 end Else_Should_Be_Elsif;
1159 -- Start of processing for P_If_Statement
1162 If_Node := New_Node (N_If_Statement, Token_Ptr);
1165 Scope.Table (Scope.Last).Etyp := E_If;
1166 Scope.Table (Scope.Last).Ecol := Start_Column;
1167 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1168 Scope.Table (Scope.Last).Labl := Error;
1169 Scope.Table (Scope.Last).Node := If_Node;
1171 if Token = Tok_If then
1174 Set_Condition (If_Node, P_Condition);
1176 -- Deal with misuse of IF expression => used instead
1177 -- of WHEN expression =>
1179 if Token = Tok_Arrow then
1180 Error_Msg_SC ("THEN expected");
1181 Scan; -- past the arrow
1182 Pop_Scope_Stack; -- remove unneeded entry
1189 Error_Msg_SC ("no IF for this THEN");
1190 Set_Condition (If_Node, Error);
1196 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1198 -- This loop scans out else and elsif parts
1201 if Token = Tok_Elsif then
1204 if Present (Else_Statements (If_Node)) then
1205 Error_Msg_SP ("ELSIF cannot appear after ELSE");
1211 elsif Token = Tok_Else then
1215 if Else_Should_Be_Elsif then
1216 Error_Msg_SP ("ELSE should be ELSIF");
1220 -- Here we have an else that really is an else
1222 if Present (Else_Statements (If_Node)) then
1223 Error_Msg_SP ("only one ELSE part allowed");
1225 (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
1226 Else_Statements (If_Node));
1229 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1233 -- If anything other than ELSE or ELSIF, exit the loop. The token
1234 -- had better be END (and in fact it had better be END IF), but
1235 -- we will let End_Statements take care of checking that.
1247 --------------------
1249 --------------------
1251 -- CONDITION ::= boolean_EXPRESSION
1253 function P_Condition return Node_Id is
1257 Cond := P_Expression_No_Right_Paren;
1259 -- It is never possible for := to follow a condition, so if we get
1260 -- a := we assume it is a mistyped equality. Note that we do not try
1261 -- to reconstruct the tree correctly in this case, but we do at least
1262 -- give an accurate error message.
1264 if Token = Tok_Colon_Equal then
1265 while Token = Tok_Colon_Equal loop
1266 Error_Msg_SC (""":="" should be ""=""");
1267 Scan; -- past junk :=
1268 Discard_Junk_Node (P_Expression_No_Right_Paren);
1273 -- Otherwise check for redundant parens
1277 and then Paren_Count (Cond) > 0
1279 Style.Check_Xtra_Parens (First_Sloc (Cond));
1282 -- And return the result
1288 -------------------------
1289 -- 5.4 Case Statement --
1290 -------------------------
1292 -- CASE_STATEMENT ::=
1293 -- case EXPRESSION is
1294 -- CASE_STATEMENT_ALTERNATIVE
1295 -- {CASE_STATEMENT_ALTERNATIVE}
1298 -- The caller has checked that the first token is CASE
1300 -- Can raise Error_Resync
1302 function P_Case_Statement return Node_Id is
1303 Case_Node : Node_Id;
1304 Alternatives_List : List_Id;
1305 First_When_Loc : Source_Ptr;
1308 Case_Node := New_Node (N_Case_Statement, Token_Ptr);
1311 Scope.Table (Scope.Last).Etyp := E_Case;
1312 Scope.Table (Scope.Last).Ecol := Start_Column;
1313 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1314 Scope.Table (Scope.Last).Labl := Error;
1315 Scope.Table (Scope.Last).Node := Case_Node;
1318 Set_Expression (Case_Node, P_Expression_No_Right_Paren);
1321 -- Prepare to parse case statement alternatives
1323 Alternatives_List := New_List;
1324 P_Pragmas_Opt (Alternatives_List);
1325 First_When_Loc := Token_Ptr;
1327 -- Loop through case statement alternatives
1330 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1331 -- that it is a semantic check to ensure the proper use of OTHERS
1333 if Token = Tok_When or else Token = Tok_Others then
1334 Append (P_Case_Statement_Alternative, Alternatives_List);
1336 -- If we have an END, then probably we are at the end of the case
1337 -- but we only exit if Check_End thinks the END was reasonable.
1339 elsif Token = Tok_End then
1340 exit when Check_End;
1342 -- Here if token is other than WHEN, OTHERS or END. We definitely
1343 -- have an error, but the question is whether or not to get out of
1344 -- the case statement. We don't want to get out early, or we will
1345 -- get a slew of junk error messages for subsequent when tokens.
1347 -- If the token is not at the start of the line, or if it is indented
1348 -- with respect to the current case statement, then the best guess is
1349 -- that we are still supposed to be inside the case statement. We
1350 -- complain about the missing WHEN, and discard the junk statements.
1352 elsif not Token_Is_At_Start_Of_Line
1353 or else Start_Column > Scope.Table (Scope.Last).Ecol
1355 Error_Msg_BC ("WHEN (case statement alternative) expected");
1357 -- Here is a possibility for infinite looping if we don't make
1358 -- progress. So try to process statements, otherwise exit
1361 Error_Ptr : constant Source_Ptr := Scan_Ptr;
1363 Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm));
1364 exit when Scan_Ptr = Error_Ptr and then Check_End;
1367 -- Here we have a junk token at the start of the line and it is
1368 -- not indented. If Check_End thinks there is a missing END, then
1369 -- we will get out of the case, otherwise we keep going.
1372 exit when Check_End;
1376 -- Make sure we have at least one alternative
1378 if No (First_Non_Pragma (Alternatives_List)) then
1380 ("WHEN expected, must have at least one alternative in case",
1385 Set_Alternatives (Case_Node, Alternatives_List);
1388 end P_Case_Statement;
1390 -------------------------------------
1391 -- 5.4 Case Statement Alternative --
1392 -------------------------------------
1394 -- CASE_STATEMENT_ALTERNATIVE ::=
1395 -- when DISCRETE_CHOICE_LIST =>
1396 -- SEQUENCE_OF_STATEMENTS
1398 -- The caller has checked that the initial token is WHEN or OTHERS
1399 -- Error recovery: can raise Error_Resync
1401 function P_Case_Statement_Alternative return Node_Id is
1402 Case_Alt_Node : Node_Id;
1406 Style.Check_Indentation;
1409 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
1410 T_When; -- past WHEN (or give error in OTHERS case)
1411 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
1413 Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
1414 return Case_Alt_Node;
1415 end P_Case_Statement_Alternative;
1417 -------------------------
1418 -- 5.5 Loop Statement --
1419 -------------------------
1421 -- LOOP_STATEMENT ::=
1422 -- [LOOP_STATEMENT_IDENTIFIER:]
1423 -- [ITERATION_SCHEME] loop
1424 -- SEQUENCE_OF_STATEMENTS
1425 -- end loop [loop_IDENTIFIER];
1427 -- ITERATION_SCHEME ::=
1429 -- | for LOOP_PARAMETER_SPECIFICATION
1431 -- The parsing of loop statements is handled by one of three functions
1432 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1433 -- on the initial keyword in the construct (excluding the identifier)
1437 -- This function parses the case where no iteration scheme is present
1439 -- The caller has checked that the initial token is LOOP. The parameter
1440 -- is the node identifiers for the loop label if any (or is set to Empty
1441 -- if there is no loop label).
1443 -- Error recovery : cannot raise Error_Resync
1445 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1446 Loop_Node : Node_Id;
1447 Created_Name : Node_Id;
1451 Scope.Table (Scope.Last).Labl := Loop_Name;
1452 Scope.Table (Scope.Last).Ecol := Start_Column;
1453 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1454 Scope.Table (Scope.Last).Etyp := E_Loop;
1456 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1459 if No (Loop_Name) then
1461 Make_Identifier (Sloc (Loop_Node),
1462 Chars => Set_Loop_Block_Name ('L'));
1463 Set_Comes_From_Source (Created_Name, False);
1464 Set_Has_Created_Identifier (Loop_Node, True);
1465 Set_Identifier (Loop_Node, Created_Name);
1466 Scope.Table (Scope.Last).Labl := Created_Name;
1468 Set_Identifier (Loop_Node, Loop_Name);
1471 Append_Elmt (Loop_Node, Label_List);
1472 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1473 End_Statements (Loop_Node);
1475 end P_Loop_Statement;
1479 -- This function parses a loop statement with a FOR iteration scheme
1481 -- The caller has checked that the initial token is FOR. The parameter
1482 -- is the node identifier for the block label if any (or is set to Empty
1483 -- if there is no block label).
1485 -- Note: the caller fills in the Identifier field if a label was present
1487 -- Error recovery: can raise Error_Resync
1489 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1490 Loop_Node : Node_Id;
1491 Iter_Scheme_Node : Node_Id;
1492 Loop_For_Flag : Boolean;
1493 Created_Name : Node_Id;
1497 Scope.Table (Scope.Last).Labl := Loop_Name;
1498 Scope.Table (Scope.Last).Ecol := Start_Column;
1499 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1500 Scope.Table (Scope.Last).Etyp := E_Loop;
1502 Loop_For_Flag := (Prev_Token = Tok_Loop);
1504 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1505 Set_Loop_Parameter_Specification
1506 (Iter_Scheme_Node, P_Loop_Parameter_Specification);
1508 -- The following is a special test so that a miswritten for loop such
1509 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1510 -- entry in the scope stack. We don't bother to actually fix up the
1511 -- tree in this case since it's not worth the effort. Instead we just
1512 -- eat up the loop junk, leaving the entry for what now looks like an
1513 -- unmodified loop intact.
1515 if Loop_For_Flag and then Token = Tok_Semicolon then
1516 Error_Msg_SC ("LOOP belongs here, not before FOR");
1523 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1525 if No (Loop_Name) then
1527 Make_Identifier (Sloc (Loop_Node),
1528 Chars => Set_Loop_Block_Name ('L'));
1529 Set_Comes_From_Source (Created_Name, False);
1530 Set_Has_Created_Identifier (Loop_Node, True);
1531 Set_Identifier (Loop_Node, Created_Name);
1532 Scope.Table (Scope.Last).Labl := Created_Name;
1534 Set_Identifier (Loop_Node, Loop_Name);
1538 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1539 End_Statements (Loop_Node);
1540 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1541 Append_Elmt (Loop_Node, Label_List);
1544 end P_For_Statement;
1546 -- P_While_Statement
1548 -- This procedure scans a loop statement with a WHILE iteration scheme
1550 -- The caller has checked that the initial token is WHILE. The parameter
1551 -- is the node identifier for the block label if any (or is set to Empty
1552 -- if there is no block label).
1554 -- Error recovery: cannot raise Error_Resync
1556 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1557 Loop_Node : Node_Id;
1558 Iter_Scheme_Node : Node_Id;
1559 Loop_While_Flag : Boolean;
1560 Created_Name : Node_Id;
1564 Scope.Table (Scope.Last).Labl := Loop_Name;
1565 Scope.Table (Scope.Last).Ecol := Start_Column;
1566 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1567 Scope.Table (Scope.Last).Etyp := E_Loop;
1569 Loop_While_Flag := (Prev_Token = Tok_Loop);
1570 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1572 Set_Condition (Iter_Scheme_Node, P_Condition);
1574 -- The following is a special test so that a miswritten for loop such
1575 -- as "loop while I > 10;" is handled nicely, without making an extra
1576 -- entry in the scope stack. We don't bother to actually fix up the
1577 -- tree in this case since it's not worth the effort. Instead we just
1578 -- eat up the loop junk, leaving the entry for what now looks like an
1579 -- unmodified loop intact.
1581 if Loop_While_Flag and then Token = Tok_Semicolon then
1582 Error_Msg_SC ("LOOP belongs here, not before WHILE");
1589 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1592 if No (Loop_Name) then
1594 Make_Identifier (Sloc (Loop_Node),
1595 Chars => Set_Loop_Block_Name ('L'));
1596 Set_Comes_From_Source (Created_Name, False);
1597 Set_Has_Created_Identifier (Loop_Node, True);
1598 Set_Identifier (Loop_Node, Created_Name);
1599 Scope.Table (Scope.Last).Labl := Created_Name;
1601 Set_Identifier (Loop_Node, Loop_Name);
1604 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1605 End_Statements (Loop_Node);
1606 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1607 Append_Elmt (Loop_Node, Label_List);
1610 end P_While_Statement;
1612 ---------------------------------------
1613 -- 5.5 Loop Parameter Specification --
1614 ---------------------------------------
1616 -- LOOP_PARAMETER_SPECIFICATION ::=
1617 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1619 -- Error recovery: cannot raise Error_Resync
1621 function P_Loop_Parameter_Specification return Node_Id is
1622 Loop_Param_Specification_Node : Node_Id;
1625 Scan_State : Saved_Scan_State;
1628 Loop_Param_Specification_Node :=
1629 New_Node (N_Loop_Parameter_Specification, Token_Ptr);
1631 Save_Scan_State (Scan_State);
1632 ID_Node := P_Defining_Identifier (C_In);
1633 Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
1635 if Token = Tok_Left_Paren then
1636 Error_Msg_SC ("subscripted loop parameter not allowed");
1637 Restore_Scan_State (Scan_State);
1638 Discard_Junk_Node (P_Name);
1640 elsif Token = Tok_Dot then
1641 Error_Msg_SC ("selected loop parameter not allowed");
1642 Restore_Scan_State (Scan_State);
1643 Discard_Junk_Node (P_Name);
1648 if Token = Tok_Reverse then
1649 Scan; -- past REVERSE
1650 Set_Reverse_Present (Loop_Param_Specification_Node, True);
1653 Set_Discrete_Subtype_Definition
1654 (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
1655 return Loop_Param_Specification_Node;
1658 when Error_Resync =>
1660 end P_Loop_Parameter_Specification;
1662 --------------------------
1663 -- 5.6 Block Statement --
1664 --------------------------
1666 -- BLOCK_STATEMENT ::=
1667 -- [block_STATEMENT_IDENTIFIER:]
1669 -- DECLARATIVE_PART]
1671 -- HANDLED_SEQUENCE_OF_STATEMENTS
1672 -- end [block_IDENTIFIER];
1674 -- The parsing of block statements is handled by one of the two functions
1675 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1676 -- a declare section is present
1678 -- P_Declare_Statement
1680 -- This function parses a block statement with DECLARE present
1682 -- The caller has checked that the initial token is DECLARE
1684 -- Error recovery: cannot raise Error_Resync
1686 function P_Declare_Statement
1687 (Block_Name : Node_Id := Empty)
1690 Block_Node : Node_Id;
1691 Created_Name : Node_Id;
1694 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1697 Scope.Table (Scope.Last).Etyp := E_Name;
1698 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1699 Scope.Table (Scope.Last).Ecol := Start_Column;
1700 Scope.Table (Scope.Last).Labl := Block_Name;
1701 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1703 Scan; -- past DECLARE
1705 if No (Block_Name) then
1707 Make_Identifier (Sloc (Block_Node),
1708 Chars => Set_Loop_Block_Name ('B'));
1709 Set_Comes_From_Source (Created_Name, False);
1710 Set_Has_Created_Identifier (Block_Node, True);
1711 Set_Identifier (Block_Node, Created_Name);
1712 Scope.Table (Scope.Last).Labl := Created_Name;
1714 Set_Identifier (Block_Node, Block_Name);
1717 Append_Elmt (Block_Node, Label_List);
1718 Parse_Decls_Begin_End (Block_Node);
1720 end P_Declare_Statement;
1722 -- P_Begin_Statement
1724 -- This function parses a block statement with no DECLARE present
1726 -- The caller has checked that the initial token is BEGIN
1728 -- Error recovery: cannot raise Error_Resync
1730 function P_Begin_Statement
1731 (Block_Name : Node_Id := Empty)
1734 Block_Node : Node_Id;
1735 Created_Name : Node_Id;
1738 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1741 Scope.Table (Scope.Last).Etyp := E_Name;
1742 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1743 Scope.Table (Scope.Last).Ecol := Start_Column;
1744 Scope.Table (Scope.Last).Labl := Block_Name;
1745 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1747 if No (Block_Name) then
1749 Make_Identifier (Sloc (Block_Node),
1750 Chars => Set_Loop_Block_Name ('B'));
1751 Set_Comes_From_Source (Created_Name, False);
1752 Set_Has_Created_Identifier (Block_Node, True);
1753 Set_Identifier (Block_Node, Created_Name);
1754 Scope.Table (Scope.Last).Labl := Created_Name;
1756 Set_Identifier (Block_Node, Block_Name);
1759 Append_Elmt (Block_Node, Label_List);
1761 Scope.Table (Scope.Last).Ecol := Start_Column;
1762 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1764 Set_Handled_Statement_Sequence
1765 (Block_Node, P_Handled_Sequence_Of_Statements);
1766 End_Statements (Handled_Statement_Sequence (Block_Node));
1768 end P_Begin_Statement;
1770 -------------------------
1771 -- 5.7 Exit Statement --
1772 -------------------------
1774 -- EXIT_STATEMENT ::=
1775 -- exit [loop_NAME] [when CONDITION];
1777 -- The caller has checked that the initial token is EXIT
1779 -- Error recovery: can raise Error_Resync
1781 function P_Exit_Statement return Node_Id is
1782 Exit_Node : Node_Id;
1784 function Missing_Semicolon_On_Exit return Boolean;
1785 -- This function deals with the following specialized situation
1788 -- exit [identifier]
1791 -- This looks like a messed up EXIT WHEN, when in fact the problem
1792 -- is a missing semicolon. It is called with Token pointing to the
1793 -- WHEN token, and returns True if a semicolon is missing before
1794 -- the WHEN as in the above example.
1796 -------------------------------
1797 -- Missing_Semicolon_On_Exit --
1798 -------------------------------
1800 function Missing_Semicolon_On_Exit return Boolean is
1801 State : Saved_Scan_State;
1804 if not Token_Is_At_Start_Of_Line then
1807 elsif Scope.Table (Scope.Last).Etyp /= E_Case then
1811 Save_Scan_State (State);
1813 Scan; -- past token after WHEN
1815 if Token = Tok_Arrow then
1816 Restore_Scan_State (State);
1819 Restore_Scan_State (State);
1823 end Missing_Semicolon_On_Exit;
1825 -- Start of processing for P_Exit_Statement
1828 Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
1831 if Token = Tok_Identifier then
1832 Set_Name (Exit_Node, P_Qualified_Simple_Name);
1834 elsif Style_Check then
1835 -- This EXIT has no name, so check that
1836 -- the innermost loop is unnamed too.
1838 Check_No_Exit_Name :
1839 for J in reverse 1 .. Scope.Last loop
1840 if Scope.Table (J).Etyp = E_Loop then
1841 if Present (Scope.Table (J).Labl)
1842 and then Comes_From_Source (Scope.Table (J).Labl)
1844 -- Innermost loop in fact had a name, style check fails
1846 Style.No_Exit_Name (Scope.Table (J).Labl);
1849 exit Check_No_Exit_Name;
1851 end loop Check_No_Exit_Name;
1854 if Token = Tok_When and then not Missing_Semicolon_On_Exit then
1856 Set_Condition (Exit_Node, P_Condition);
1858 -- Allow IF instead of WHEN, giving error message
1860 elsif Token = Tok_If then
1862 Scan; -- past IF used in place of WHEN
1863 Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
1868 end P_Exit_Statement;
1870 -------------------------
1871 -- 5.8 Goto Statement --
1872 -------------------------
1874 -- GOTO_STATEMENT ::= goto label_NAME;
1876 -- The caller has checked that the initial token is GOTO (or TO in the
1877 -- error case where GO and TO were incorrectly separated).
1879 -- Error recovery: can raise Error_Resync
1881 function P_Goto_Statement return Node_Id is
1882 Goto_Node : Node_Id;
1885 Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
1886 Scan; -- past GOTO (or TO)
1887 Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
1888 Append_Elmt (Goto_Node, Goto_List);
1892 end P_Goto_Statement;
1894 ---------------------------
1895 -- Parse_Decls_Begin_End --
1896 ---------------------------
1898 -- This function parses the construct:
1902 -- HANDLED_SEQUENCE_OF_STATEMENTS
1905 -- The caller has built the scope stack entry, and created the node to
1906 -- whose Declarations and Handled_Statement_Sequence fields are to be
1907 -- set. On return these fields are filled in (except in the case of a
1908 -- task body, where the handled statement sequence is optional, and may
1909 -- thus be Empty), and the scan is positioned past the End sequence.
1911 -- If the BEGIN is missing, then the parent node is used to help construct
1912 -- an appropriate missing BEGIN message. Possibilities for the parent are:
1914 -- N_Block_Statement declare block
1915 -- N_Entry_Body entry body
1916 -- N_Package_Body package body (begin part optional)
1917 -- N_Subprogram_Body procedure or function body
1918 -- N_Task_Body task body
1920 -- Note: in the case of a block statement, there is definitely a DECLARE
1921 -- present (because a Begin statement without a DECLARE is handled by the
1922 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
1924 -- Error recovery: cannot raise Error_Resync
1926 procedure Parse_Decls_Begin_End (Parent : Node_Id) is
1927 Body_Decl : Node_Id;
1928 Body_Sloc : Source_Ptr;
1931 Parent_Nkind : Node_Kind;
1932 Spec_Node : Node_Id;
1935 procedure Missing_Begin (Msg : String);
1936 -- Called to post a missing begin message. In the normal case this is
1937 -- posted at the start of the current token. A special case arises when
1938 -- P_Declarative_Items has previously found a missing begin, in which
1939 -- case we replace the original error message.
1941 procedure Set_Null_HSS (Parent : Node_Id);
1942 -- Construct an empty handled statement sequence and install in Parent
1943 -- Leaves HSS set to reference the newly constructed statement sequence.
1949 procedure Missing_Begin (Msg : String) is
1951 if Missing_Begin_Msg = No_Error_Msg then
1954 Change_Error_Text (Missing_Begin_Msg, Msg);
1956 -- Purge any messages issued after than, since a missing begin
1957 -- can cause a lot of havoc, and it is better not to dump these
1958 -- cascaded messages on the user.
1960 Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
1968 procedure Set_Null_HSS (Parent : Node_Id) is
1973 Make_Null_Statement (Token_Ptr);
1974 Set_Comes_From_Source (Null_Stm, False);
1977 Make_Handled_Sequence_Of_Statements (Token_Ptr,
1978 Statements => New_List (Null_Stm));
1979 Set_Comes_From_Source (HSS, False);
1981 Set_Handled_Statement_Sequence (Parent, HSS);
1984 -- Start of processing for Parse_Decls_Begin_End
1987 Decls := P_Declarative_Part;
1989 -- Check for misplacement of later vs basic declarations in Ada 83
1991 if Ada_Version = Ada_83 then
1992 Decl := First (Decls);
1994 -- Loop through sequence of basic declarative items
1996 Outer : while Present (Decl) loop
1997 if Nkind (Decl) /= N_Subprogram_Body
1998 and then Nkind (Decl) /= N_Package_Body
1999 and then Nkind (Decl) /= N_Task_Body
2000 and then Nkind (Decl) not in N_Body_Stub
2004 -- Once a body is encountered, we only allow later declarative
2005 -- items. The inner loop checks the rest of the list.
2008 Body_Sloc := Sloc (Decl);
2010 Inner : while Present (Decl) loop
2011 if Nkind (Decl) not in N_Later_Decl_Item
2012 and then Nkind (Decl) /= N_Pragma
2014 if Ada_Version = Ada_83 then
2015 Error_Msg_Sloc := Body_Sloc;
2017 ("(Ada 83) decl cannot appear after body#", Decl);
2027 -- Here is where we deal with the case of IS used instead of semicolon.
2028 -- Specifically, if the last declaration in the declarative part is a
2029 -- subprogram body still marked as having a bad IS, then this is where
2030 -- we decide that the IS should really have been a semicolon and that
2031 -- the body should have been a declaration. Note that if the bad IS
2032 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2033 -- then the Bad_Is_Detected flag would have been reset by now.
2035 Body_Decl := Last (Decls);
2037 if Present (Body_Decl)
2038 and then Nkind (Body_Decl) = N_Subprogram_Body
2039 and then Bad_Is_Detected (Body_Decl)
2041 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2042 -- What we have now is a subprogram body with attached declarations
2043 -- and a possible statement sequence.
2045 -- First step is to take the declarations that were part of the bogus
2046 -- subprogram body and append them to the outer declaration chain.
2047 -- In other words we append them past the body (which we will later
2048 -- convert into a declaration).
2050 Append_List (Declarations (Body_Decl), Decls);
2052 -- Now take the handled statement sequence of the bogus body and
2053 -- set it as the statement sequence for the outer construct. Note
2054 -- that it may be empty (we specially allowed a missing BEGIN for
2055 -- a subprogram body marked as having a bad IS -- see below).
2057 Set_Handled_Statement_Sequence (Parent,
2058 Handled_Statement_Sequence (Body_Decl));
2060 -- Next step is to convert the old body node to a declaration node
2062 Spec_Node := Specification (Body_Decl);
2063 Change_Node (Body_Decl, N_Subprogram_Declaration);
2064 Set_Specification (Body_Decl, Spec_Node);
2066 -- Final step is to put the declarations for the parent where
2067 -- they belong, and then fall through the IF to scan out the
2070 Set_Declarations (Parent, Decls);
2072 -- This is the normal case (i.e. any case except the bad IS case)
2073 -- If we have a BEGIN, then scan out the sequence of statements, and
2074 -- also reset the expected column for the END to match the BEGIN.
2077 Set_Declarations (Parent, Decls);
2079 if Token = Tok_Begin then
2081 Style.Check_Indentation;
2084 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
2086 if Style.RM_Column_Check
2087 and then Token_Is_At_Start_Of_Line
2088 and then Start_Column /= Error_Msg_Col
2090 Error_Msg_SC ("(style) BEGIN in wrong column, should be@");
2093 Scope.Table (Scope.Last).Ecol := Start_Column;
2096 Scope.Table (Scope.Last).Sloc := Token_Ptr;
2098 Set_Handled_Statement_Sequence (Parent,
2099 P_Handled_Sequence_Of_Statements);
2104 Parent_Nkind := Nkind (Parent);
2106 -- A special check for the missing IS case. If we have a
2107 -- subprogram body that was marked as having a suspicious
2108 -- IS, and the current token is END, then we simply confirm
2109 -- the suspicion, and do not require a BEGIN to be present
2111 if Parent_Nkind = N_Subprogram_Body
2112 and then Token = Tok_End
2113 and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is
2115 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
2117 -- Otherwise BEGIN is not required for a package body, so we
2118 -- don't mind if it is missing, but we do construct a dummy
2119 -- one (so that we have somewhere to set End_Label).
2121 -- However if we have something other than a BEGIN which
2122 -- looks like it might be statements, then we signal a missing
2123 -- BEGIN for these cases as well. We define "something which
2124 -- looks like it might be statements" as a token other than
2125 -- END, EOF, or a token which starts declarations.
2127 elsif Parent_Nkind = N_Package_Body
2128 and then (Token = Tok_End
2129 or else Token = Tok_EOF
2130 or else Token in Token_Class_Declk)
2132 Set_Null_HSS (Parent);
2134 -- These are cases in which a BEGIN is required and not present
2137 Set_Null_HSS (Parent);
2139 -- Prepare to issue error message
2141 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
2142 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
2144 -- Now issue appropriate message
2146 if Parent_Nkind = N_Block_Statement then
2147 Missing_Begin ("missing BEGIN for DECLARE#!");
2149 elsif Parent_Nkind = N_Entry_Body then
2150 Missing_Begin ("missing BEGIN for ENTRY#!");
2152 elsif Parent_Nkind = N_Subprogram_Body then
2153 if Nkind (Specification (Parent))
2154 = N_Function_Specification
2156 Missing_Begin ("missing BEGIN for function&#!");
2158 Missing_Begin ("missing BEGIN for procedure&#!");
2161 -- The case for package body arises only when
2162 -- we have possible statement junk present.
2164 elsif Parent_Nkind = N_Package_Body then
2165 Missing_Begin ("missing BEGIN for package body&#!");
2168 pragma Assert (Parent_Nkind = N_Task_Body);
2169 Missing_Begin ("missing BEGIN for task body&#!");
2172 -- Here we pick up the statements after the BEGIN that
2173 -- should have been present but was not. We don't insist
2174 -- on statements being present if P_Declarative_Part had
2175 -- already found a missing BEGIN, since it might have
2176 -- swallowed a lone statement into the declarative part.
2178 if Missing_Begin_Msg /= No_Error_Msg
2179 and then Token = Tok_End
2183 Set_Handled_Statement_Sequence (Parent,
2184 P_Handled_Sequence_Of_Statements);
2190 -- Here with declarations and handled statement sequence scanned
2192 if Present (Handled_Statement_Sequence (Parent)) then
2193 End_Statements (Handled_Statement_Sequence (Parent));
2198 -- We know that End_Statements removed an entry from the scope stack
2199 -- (because it is required to do so under all circumstances). We can
2200 -- therefore reference the entry it removed one past the stack top.
2201 -- What we are interested in is whether it was a case of a bad IS.
2203 if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
2204 Error_Msg ("IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
2205 Set_Bad_Is_Detected (Parent, True);
2208 end Parse_Decls_Begin_End;
2210 -------------------------
2211 -- Set_Loop_Block_Name --
2212 -------------------------
2214 function Set_Loop_Block_Name (L : Character) return Name_Id is
2216 Name_Buffer (1) := L;
2217 Name_Buffer (2) := '_';
2219 Loop_Block_Count := Loop_Block_Count + 1;
2220 Add_Nat_To_Name_Buffer (Loop_Block_Count);
2222 end Set_Loop_Block_Name;
2228 procedure Then_Scan is
2232 while Token = Tok_Then loop
2233 Error_Msg_SC ("redundant THEN");
2237 if Token = Tok_And or else Token = Tok_Or then
2238 Error_Msg_SC ("unexpected logical operator");
2241 if (Prev_Token = Tok_And and then Token = Tok_Then)
2243 (Prev_Token = Tok_Or and then Token = Tok_Else)
2248 Discard_Junk_Node (P_Expression);
2251 if Token = Tok_Then then