2014-01-30 Richard Biener <rguenther@suse.de>
[official-gcc.git] / gcc / ada / par-ch5.adb
blob2f83c3bc1e3ad946e6632fe28630a3bd20d1a27e
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P A R . C H 5 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks (All_Checks);
27 -- Turn off subprogram body ordering check. Subprograms are in order by RM
28 -- section rather than alphabetical.
30 with Sinfo.CN; use Sinfo.CN;
32 separate (Par)
33 package body Ch5 is
35 -- Local functions, used only in this chapter
37 function P_Case_Statement return Node_Id;
38 function P_Case_Statement_Alternative return Node_Id;
39 function P_Exit_Statement return Node_Id;
40 function P_Goto_Statement return Node_Id;
41 function P_If_Statement return Node_Id;
42 function P_Label return Node_Id;
43 function P_Null_Statement return Node_Id;
45 function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
46 -- Parse assignment statement. On entry, the caller has scanned the left
47 -- hand side (passed in as Lhs), and the colon-equal (or some symbol
48 -- taken to be an error equivalent such as equal).
50 function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id;
51 -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is
52 -- the N_Identifier node for the label on the block. If Block_Name is
53 -- Empty on entry (the default), then the block statement is unlabeled.
55 function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id;
56 -- Parse declare block. If Block_Name is non-Empty on entry, it is
57 -- the N_Identifier node for the label on the block. If Block_Name is
58 -- Empty on entry (the default), then the block statement is unlabeled.
60 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
61 -- Parse for statement. If Loop_Name is non-Empty on entry, it is
62 -- the N_Identifier node for the label on the loop. If Loop_Name is
63 -- Empty on entry (the default), then the for statement is unlabeled.
65 function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id;
66 -- Parse an iterator specification. The defining identifier has already
67 -- been scanned, as it is the common prefix between loop and iterator
68 -- specification.
70 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
71 -- Parse loop 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 loop statement is unlabeled.
75 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
76 -- Parse while statement. If Loop_Name is non-Empty on entry, it is
77 -- the N_Identifier node for the label on the loop. If Loop_Name is
78 -- Empty on entry (the default), then the while statement is unlabeled.
80 function Set_Loop_Block_Name (L : Character) return Name_Id;
81 -- Given a letter 'L' for a loop or 'B' for a block, returns a name
82 -- of the form L_nn or B_nn where nn is a serial number obtained by
83 -- incrementing the variable Loop_Block_Count.
85 procedure Then_Scan;
86 -- Scan past THEN token, testing for illegal junk after it
88 ---------------------------------
89 -- 5.1 Sequence of Statements --
90 ---------------------------------
92 -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} {LABEL}
93 -- Note: the final label is an Ada 2012 addition.
95 -- STATEMENT ::=
96 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
98 -- SIMPLE_STATEMENT ::= NULL_STATEMENT
99 -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT
100 -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT
101 -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT
102 -- | REQUEUE_STATEMENT | DELAY_STATEMENT
103 -- | ABORT_STATEMENT | RAISE_STATEMENT
104 -- | CODE_STATEMENT
106 -- COMPOUND_STATEMENT ::=
107 -- IF_STATEMENT | CASE_STATEMENT
108 -- | LOOP_STATEMENT | BLOCK_STATEMENT
109 -- | ACCEPT_STATEMENT | SELECT_STATEMENT
111 -- This procedure scans a sequence of statements. The caller sets SS_Flags
112 -- to indicate acceptable termination conditions for the sequence:
114 -- SS_Flags.Eftm Terminate on ELSIF
115 -- SS_Flags.Eltm Terminate on ELSE
116 -- SS_Flags.Extm Terminate on EXCEPTION
117 -- SS_Flags.Ortm Terminate on OR
118 -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return)
119 -- SS_Flags.Whtm Terminate on WHEN
120 -- SS_Flags.Unco Unconditional terminate after scanning one statement
122 -- In addition, the scan is always terminated by encountering END or the
123 -- end of file (EOF) condition. If one of the six above terminators is
124 -- encountered with the corresponding SS_Flags flag not set, then the
125 -- action taken is as follows:
127 -- If the keyword occurs to the left of the expected column of the end
128 -- for the current sequence (as recorded in the current end context),
129 -- then it is assumed to belong to an outer context, and is considered
130 -- to terminate the sequence of statements.
132 -- If the keyword occurs to the right of, or in the expected column of
133 -- the end for the current sequence, then an error message is output,
134 -- the keyword together with its associated context is skipped, and
135 -- the statement scan continues until another terminator is found.
137 -- Note that the first action means that control can return to the caller
138 -- with Token set to a terminator other than one of those specified by the
139 -- SS parameter. The caller should treat such a case as equivalent to END.
141 -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at
142 -- least one real statement (other than a pragma) is required in the
143 -- statement sequence. During the processing of the sequence, this
144 -- flag is manipulated to indicate the current status of the requirement
145 -- for a statement. For example, it is turned off by the occurrence of a
146 -- statement, and back on by a label (which requires a following statement)
148 -- Error recovery: cannot raise Error_Resync. If an error occurs during
149 -- parsing a statement, then the scan pointer is advanced past the next
150 -- semicolon and the parse continues.
152 function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is
154 Statement_Required : Boolean;
155 -- This flag indicates if a subsequent statement (other than a pragma)
156 -- is required. It is initialized from the Sreq flag, and modified as
157 -- statements are scanned (a statement turns it off, and a label turns
158 -- it back on again since a statement must follow a label).
159 -- Note : this final requirement is lifted in Ada 2012.
161 Statement_Seen : Boolean;
162 -- In Ada 2012, a label can end a sequence of statements, but the
163 -- sequence cannot contain only labels. This flag is set whenever a
164 -- label is encountered, to enforce this rule at the end of a sequence.
166 Declaration_Found : Boolean := False;
167 -- This flag is set True if a declaration is encountered, so that the
168 -- error message about declarations in the statement part is only
169 -- given once for a given sequence of statements.
171 Scan_State_Label : Saved_Scan_State;
172 Scan_State : Saved_Scan_State;
174 Statement_List : List_Id;
175 Block_Label : Name_Id;
176 Id_Node : Node_Id;
177 Name_Node : Node_Id;
179 procedure Junk_Declaration;
180 -- Procedure called to handle error of declaration encountered in
181 -- statement sequence.
183 procedure Test_Statement_Required;
184 -- Flag error if Statement_Required flag set
186 ----------------------
187 -- Junk_Declaration --
188 ----------------------
190 procedure Junk_Declaration is
191 begin
192 if (not Declaration_Found) or All_Errors_Mode then
193 Error_Msg_SC -- CODEFIX
194 ("declarations must come before BEGIN");
195 Declaration_Found := True;
196 end if;
198 Skip_Declaration (Statement_List);
199 end Junk_Declaration;
201 -----------------------------
202 -- Test_Statement_Required --
203 -----------------------------
205 procedure Test_Statement_Required is
206 function All_Pragmas return Boolean;
207 -- Return True if statement list is all pragmas
209 -----------------
210 -- All_Pragmas --
211 -----------------
213 function All_Pragmas return Boolean is
214 S : Node_Id;
215 begin
216 S := First (Statement_List);
217 while Present (S) loop
218 if Nkind (S) /= N_Pragma then
219 return False;
220 else
221 Next (S);
222 end if;
223 end loop;
225 return True;
226 end All_Pragmas;
228 -- Start of processing for Test_Statement_Required
230 begin
231 if Statement_Required then
233 -- Check no statement required after label in Ada 2012, and that
234 -- it is OK to have nothing but pragmas in a statement sequence.
236 if Ada_Version >= Ada_2012
237 and then not Is_Empty_List (Statement_List)
238 and then
239 ((Nkind (Last (Statement_List)) = N_Label
240 and then Statement_Seen)
241 or else All_Pragmas)
242 then
243 declare
244 Null_Stm : constant Node_Id :=
245 Make_Null_Statement (Token_Ptr);
246 begin
247 Set_Comes_From_Source (Null_Stm, False);
248 Append_To (Statement_List, Null_Stm);
249 end;
251 -- If not Ada 2012, or not special case above, give error message
253 else
254 Error_Msg_BC -- CODEFIX
255 ("statement expected");
256 end if;
257 end if;
258 end Test_Statement_Required;
260 -- Start of processing for P_Sequence_Of_Statements
262 begin
263 Statement_List := New_List;
264 Statement_Required := SS_Flags.Sreq;
265 Statement_Seen := False;
267 loop
268 Ignore (Tok_Semicolon);
270 begin
271 if Style_Check then
272 Style.Check_Indentation;
273 end if;
275 -- Deal with reserved identifier (in assignment or call)
277 if Is_Reserved_Identifier then
278 Save_Scan_State (Scan_State); -- at possible bad identifier
279 Scan; -- and scan past it
281 -- We have an reserved word which is spelled in identifier
282 -- style, so the question is whether it really is intended
283 -- to be an identifier.
286 -- If followed by a semicolon, then it is an identifier,
287 -- with the exception of the cases tested for below.
289 (Token = Tok_Semicolon
290 and then Prev_Token /= Tok_Return
291 and then Prev_Token /= Tok_Null
292 and then Prev_Token /= Tok_Raise
293 and then Prev_Token /= Tok_End
294 and then Prev_Token /= Tok_Exit)
296 -- If followed by colon, colon-equal, or dot, then we
297 -- definitely have an identifier (could not be reserved)
299 or else Token = Tok_Colon
300 or else Token = Tok_Colon_Equal
301 or else Token = Tok_Dot
303 -- Left paren means we have an identifier except for those
304 -- reserved words that can legitimately be followed by a
305 -- left paren.
307 or else
308 (Token = Tok_Left_Paren
309 and then Prev_Token /= Tok_Case
310 and then Prev_Token /= Tok_Delay
311 and then Prev_Token /= Tok_If
312 and then Prev_Token /= Tok_Elsif
313 and then Prev_Token /= Tok_Return
314 and then Prev_Token /= Tok_When
315 and then Prev_Token /= Tok_While
316 and then Prev_Token /= Tok_Separate)
317 then
318 -- Here we have an apparent reserved identifier and the
319 -- token past it is appropriate to this usage (and would
320 -- be a definite error if this is not an identifier). What
321 -- we do is to use P_Identifier to fix up the identifier,
322 -- and then fall into the normal processing.
324 Restore_Scan_State (Scan_State); -- back to the ID
325 Scan_Reserved_Identifier (Force_Msg => False);
327 -- Not a reserved identifier after all (or at least we can't
328 -- be sure that it is), so reset the scan and continue.
330 else
331 Restore_Scan_State (Scan_State); -- back to the reserved word
332 end if;
333 end if;
335 -- Now look to see what kind of statement we have
337 case Token is
339 -- Case of end or EOF
341 when Tok_End | Tok_EOF =>
343 -- These tokens always terminate the statement sequence
345 Test_Statement_Required;
346 exit;
348 -- Case of ELSIF
350 when Tok_Elsif =>
352 -- Terminate if Eftm set or if the ELSIF is to the left
353 -- of the expected column of the end for this sequence
355 if SS_Flags.Eftm
356 or else Start_Column < Scope.Table (Scope.Last).Ecol
357 then
358 Test_Statement_Required;
359 exit;
361 -- Otherwise complain and skip past ELSIF Condition then
363 else
364 Error_Msg_SC ("ELSIF not allowed here");
365 Scan; -- past ELSIF
366 Discard_Junk_Node (P_Expression_No_Right_Paren);
367 Then_Scan;
368 Statement_Required := False;
369 end if;
371 -- Case of ELSE
373 when Tok_Else =>
375 -- Terminate if Eltm set or if the else is to the left
376 -- of the expected column of the end for this sequence
378 if SS_Flags.Eltm
379 or else Start_Column < Scope.Table (Scope.Last).Ecol
380 then
381 Test_Statement_Required;
382 exit;
384 -- Otherwise complain and skip past else
386 else
387 Error_Msg_SC ("ELSE not allowed here");
388 Scan; -- past ELSE
389 Statement_Required := False;
390 end if;
392 -- Case of exception
394 when Tok_Exception =>
395 Test_Statement_Required;
397 -- If Extm not set and the exception is not to the left of
398 -- the expected column of the end for this sequence, then we
399 -- assume it belongs to the current sequence, even though it
400 -- is not permitted.
402 if not SS_Flags.Extm and then
403 Start_Column >= Scope.Table (Scope.Last).Ecol
405 then
406 Error_Msg_SC ("exception handler not permitted here");
407 Scan; -- past EXCEPTION
408 Discard_Junk_List (Parse_Exception_Handlers);
409 end if;
411 -- Always return, in the case where we scanned out handlers
412 -- that we did not expect, Parse_Exception_Handlers returned
413 -- with Token being either end or EOF, so we are OK.
415 exit;
417 -- Case of OR
419 when Tok_Or =>
421 -- Terminate if Ortm set or if the or is to the left of the
422 -- expected column of the end for this sequence.
424 if SS_Flags.Ortm
425 or else Start_Column < Scope.Table (Scope.Last).Ecol
426 then
427 Test_Statement_Required;
428 exit;
430 -- Otherwise complain and skip past or
432 else
433 Error_Msg_SC ("OR not allowed here");
434 Scan; -- past or
435 Statement_Required := False;
436 end if;
438 -- Case of THEN (deal also with THEN ABORT)
440 when Tok_Then =>
441 Save_Scan_State (Scan_State); -- at THEN
442 Scan; -- past THEN
444 -- Terminate if THEN ABORT allowed (ATC case)
446 exit when SS_Flags.Tatm and then Token = Tok_Abort;
448 -- Otherwise we treat THEN as some kind of mess where we did
449 -- not see the associated IF, but we pick up assuming it had
450 -- been there.
452 Restore_Scan_State (Scan_State); -- to THEN
453 Append_To (Statement_List, P_If_Statement);
454 Statement_Required := False;
456 -- Case of WHEN (error because we are not in a case)
458 when Tok_When | Tok_Others =>
460 -- Terminate if Whtm set or if the WHEN is to the left of
461 -- the expected column of the end for this sequence.
463 if SS_Flags.Whtm
464 or else Start_Column < Scope.Table (Scope.Last).Ecol
465 then
466 Test_Statement_Required;
467 exit;
469 -- Otherwise complain and skip when Choice {| Choice} =>
471 else
472 Error_Msg_SC ("WHEN not allowed here");
473 Scan; -- past when
474 Discard_Junk_List (P_Discrete_Choice_List);
475 TF_Arrow;
476 Statement_Required := False;
477 end if;
479 -- Cases of statements starting with an identifier
481 when Tok_Identifier =>
482 Check_Bad_Layout;
484 -- Save scan pointers and line number in case block label
486 Id_Node := Token_Node;
487 Block_Label := Token_Name;
488 Save_Scan_State (Scan_State_Label); -- at possible label
489 Scan; -- past Id
491 -- Check for common case of assignment, since it occurs
492 -- frequently, and we want to process it efficiently.
494 if Token = Tok_Colon_Equal then
495 Scan; -- past the colon-equal
496 Append_To (Statement_List,
497 P_Assignment_Statement (Id_Node));
498 Statement_Required := False;
500 -- Check common case of procedure call, another case that
501 -- we want to speed up as much as possible.
503 elsif Token = Tok_Semicolon then
504 Change_Name_To_Procedure_Call_Statement (Id_Node);
505 Append_To (Statement_List, Id_Node);
506 Scan; -- past semicolon
507 Statement_Required := False;
509 -- Here is the special test for a suspicious label, more
510 -- accurately a suspicious name, which we think perhaps
511 -- should have been a label. If next token is one of
512 -- LOOP, FOR, WHILE, DECLARE, BEGIN, then make an entry
513 -- in the suspicious label table.
515 if Token = Tok_Loop or else
516 Token = Tok_For or else
517 Token = Tok_While or else
518 Token = Tok_Declare or else
519 Token = Tok_Begin
520 then
521 Suspicious_Labels.Append
522 ((Proc_Call => Id_Node,
523 Semicolon_Loc => Prev_Token_Ptr,
524 Start_Token => Token_Ptr));
525 end if;
527 -- Check for case of "go to" in place of "goto"
529 elsif Token = Tok_Identifier
530 and then Block_Label = Name_Go
531 and then Token_Name = Name_To
532 then
533 Error_Msg_SP -- CODEFIX
534 ("goto is one word");
535 Append_To (Statement_List, P_Goto_Statement);
536 Statement_Required := False;
538 -- Check common case of = used instead of :=, just so we
539 -- give a better error message for this special misuse.
541 elsif Token = Tok_Equal then
542 T_Colon_Equal; -- give := expected message
543 Append_To (Statement_List,
544 P_Assignment_Statement (Id_Node));
545 Statement_Required := False;
547 -- Check case of loop label or block label
549 elsif Token = Tok_Colon
550 or else (Token in Token_Class_Labeled_Stmt
551 and then not Token_Is_At_Start_Of_Line)
552 then
553 T_Colon; -- past colon (if there, or msg for missing one)
555 -- Test for more than one label
557 loop
558 exit when Token /= Tok_Identifier;
559 Save_Scan_State (Scan_State); -- at second Id
560 Scan; -- past Id
562 if Token = Tok_Colon then
563 Error_Msg_SP
564 ("only one label allowed on block or loop");
565 Scan; -- past colon on extra label
567 -- Use the second label as the "real" label
569 Scan_State_Label := Scan_State;
571 -- We will set Error_name as the Block_Label since
572 -- we really don't know which of the labels might
573 -- be used at the end of the loop or block.
575 Block_Label := Error_Name;
577 -- If Id with no colon, then backup to point to the
578 -- Id and we will issue the message below when we try
579 -- to scan out the statement as some other form.
581 else
582 Restore_Scan_State (Scan_State); -- to second Id
583 exit;
584 end if;
585 end loop;
587 -- Loop_Statement (labeled Loop_Statement)
589 if Token = Tok_Loop then
590 Append_To (Statement_List,
591 P_Loop_Statement (Id_Node));
593 -- While statement (labeled loop statement with WHILE)
595 elsif Token = Tok_While then
596 Append_To (Statement_List,
597 P_While_Statement (Id_Node));
599 -- Declare statement (labeled block statement with
600 -- DECLARE part)
602 elsif Token = Tok_Declare then
603 Append_To (Statement_List,
604 P_Declare_Statement (Id_Node));
606 -- Begin statement (labeled block statement with no
607 -- DECLARE part)
609 elsif Token = Tok_Begin then
610 Append_To (Statement_List,
611 P_Begin_Statement (Id_Node));
613 -- For statement (labeled loop statement with FOR)
615 elsif Token = Tok_For then
616 Append_To (Statement_List,
617 P_For_Statement (Id_Node));
619 -- Improper statement follows label. If we have an
620 -- expression token, then assume the colon was part
621 -- of a misplaced declaration.
623 elsif Token not in Token_Class_Eterm then
624 Restore_Scan_State (Scan_State_Label);
625 Junk_Declaration;
627 -- Otherwise complain we have inappropriate statement
629 else
630 Error_Msg_AP
631 ("loop or block statement must follow label");
632 end if;
634 Statement_Required := False;
636 -- Here we have an identifier followed by something
637 -- other than a colon, semicolon or assignment symbol.
638 -- The only valid possibility is a name extension symbol
640 elsif Token in Token_Class_Namext then
641 Restore_Scan_State (Scan_State_Label); -- to Id
642 Name_Node := P_Name;
644 -- Skip junk right parens in this context
646 Ignore (Tok_Right_Paren);
648 -- Check context following call
650 if Token = Tok_Colon_Equal then
651 Scan; -- past colon equal
652 Append_To (Statement_List,
653 P_Assignment_Statement (Name_Node));
654 Statement_Required := False;
656 -- Check common case of = used instead of :=
658 elsif Token = Tok_Equal then
659 T_Colon_Equal; -- give := expected message
660 Append_To (Statement_List,
661 P_Assignment_Statement (Name_Node));
662 Statement_Required := False;
664 -- Check apostrophe cases
666 elsif Token = Tok_Apostrophe then
667 Append_To (Statement_List,
668 P_Code_Statement (Name_Node));
669 Statement_Required := False;
671 -- The only other valid item after a name is ; which
672 -- means that the item we just scanned was a call.
674 elsif Token = Tok_Semicolon then
675 Change_Name_To_Procedure_Call_Statement (Name_Node);
676 Append_To (Statement_List, Name_Node);
677 Scan; -- past semicolon
678 Statement_Required := False;
680 -- A slash following an identifier or a selected
681 -- component in this situation is most likely a period
682 -- (see location of keys on keyboard).
684 elsif Token = Tok_Slash
685 and then (Nkind (Name_Node) = N_Identifier
686 or else
687 Nkind (Name_Node) = N_Selected_Component)
688 then
689 Error_Msg_SC -- CODEFIX
690 ("""/"" should be "".""");
691 Statement_Required := False;
692 raise Error_Resync;
694 -- Else we have a missing semicolon
696 else
697 TF_Semicolon;
698 Statement_Required := False;
699 end if;
701 -- If junk after identifier, check if identifier is an
702 -- instance of an incorrectly spelled keyword. If so, we
703 -- do nothing. The Bad_Spelling_Of will have reset Token
704 -- to the appropriate keyword, so the next time round the
705 -- loop we will process the modified token. Note that we
706 -- check for ELSIF before ELSE here. That's not accidental.
707 -- We don't want to identify a misspelling of ELSE as
708 -- ELSIF, and in particular we do not want to treat ELSEIF
709 -- as ELSE IF.
711 else
712 Restore_Scan_State (Scan_State_Label); -- to identifier
714 if Bad_Spelling_Of (Tok_Abort)
715 or else Bad_Spelling_Of (Tok_Accept)
716 or else Bad_Spelling_Of (Tok_Case)
717 or else Bad_Spelling_Of (Tok_Declare)
718 or else Bad_Spelling_Of (Tok_Delay)
719 or else Bad_Spelling_Of (Tok_Elsif)
720 or else Bad_Spelling_Of (Tok_Else)
721 or else Bad_Spelling_Of (Tok_End)
722 or else Bad_Spelling_Of (Tok_Exception)
723 or else Bad_Spelling_Of (Tok_Exit)
724 or else Bad_Spelling_Of (Tok_For)
725 or else Bad_Spelling_Of (Tok_Goto)
726 or else Bad_Spelling_Of (Tok_If)
727 or else Bad_Spelling_Of (Tok_Loop)
728 or else Bad_Spelling_Of (Tok_Or)
729 or else Bad_Spelling_Of (Tok_Pragma)
730 or else Bad_Spelling_Of (Tok_Raise)
731 or else Bad_Spelling_Of (Tok_Requeue)
732 or else Bad_Spelling_Of (Tok_Return)
733 or else Bad_Spelling_Of (Tok_Select)
734 or else Bad_Spelling_Of (Tok_When)
735 or else Bad_Spelling_Of (Tok_While)
736 then
737 null;
739 -- If not a bad spelling, then we really have junk
741 else
742 Scan; -- past identifier again
744 -- If next token is first token on line, then we
745 -- consider that we were missing a semicolon after
746 -- the identifier, and process it as a procedure
747 -- call with no parameters.
749 if Token_Is_At_Start_Of_Line then
750 Change_Name_To_Procedure_Call_Statement (Id_Node);
751 Append_To (Statement_List, Id_Node);
752 T_Semicolon; -- to give error message
753 Statement_Required := False;
755 -- Otherwise we give a missing := message and
756 -- simply abandon the junk that is there now.
758 else
759 T_Colon_Equal; -- give := expected message
760 raise Error_Resync;
761 end if;
763 end if;
764 end if;
766 -- Statement starting with operator symbol. This could be
767 -- a call, a name starting an assignment, or a qualified
768 -- expression.
770 when Tok_Operator_Symbol =>
771 Check_Bad_Layout;
772 Name_Node := P_Name;
774 -- An attempt at a range attribute or a qualified expression
775 -- must be illegal here (a code statement cannot possibly
776 -- allow qualification by a function name).
778 if Token = Tok_Apostrophe then
779 Error_Msg_SC ("apostrophe illegal here");
780 raise Error_Resync;
781 end if;
783 -- Scan possible assignment if we have a name
785 if Expr_Form = EF_Name
786 and then Token = Tok_Colon_Equal
787 then
788 Scan; -- past colon equal
789 Append_To (Statement_List,
790 P_Assignment_Statement (Name_Node));
791 else
792 Change_Name_To_Procedure_Call_Statement (Name_Node);
793 Append_To (Statement_List, Name_Node);
794 end if;
796 TF_Semicolon;
797 Statement_Required := False;
799 -- Label starting with << which must precede real statement
800 -- Note: in Ada 2012, the label may end the sequence.
802 when Tok_Less_Less =>
803 if Present (Last (Statement_List))
804 and then Nkind (Last (Statement_List)) /= N_Label
805 then
806 Statement_Seen := True;
807 end if;
809 Append_To (Statement_List, P_Label);
810 Statement_Required := True;
812 -- Pragma appearing as a statement in a statement sequence
814 when Tok_Pragma =>
815 Check_Bad_Layout;
816 Append_To (Statement_List, P_Pragma);
818 -- Abort_Statement
820 when Tok_Abort =>
821 Check_Bad_Layout;
822 Append_To (Statement_List, P_Abort_Statement);
823 Statement_Required := False;
825 -- Accept_Statement
827 when Tok_Accept =>
828 Check_Bad_Layout;
829 Append_To (Statement_List, P_Accept_Statement);
830 Statement_Required := False;
832 -- Begin_Statement (Block_Statement with no declare, no label)
834 when Tok_Begin =>
835 Check_Bad_Layout;
836 Append_To (Statement_List, P_Begin_Statement);
837 Statement_Required := False;
839 -- Case_Statement
841 when Tok_Case =>
842 Check_Bad_Layout;
843 Append_To (Statement_List, P_Case_Statement);
844 Statement_Required := False;
846 -- Block_Statement with DECLARE and no label
848 when Tok_Declare =>
849 Check_Bad_Layout;
850 Append_To (Statement_List, P_Declare_Statement);
851 Statement_Required := False;
853 -- Delay_Statement
855 when Tok_Delay =>
856 Check_Bad_Layout;
857 Append_To (Statement_List, P_Delay_Statement);
858 Statement_Required := False;
860 -- Exit_Statement
862 when Tok_Exit =>
863 Check_Bad_Layout;
864 Append_To (Statement_List, P_Exit_Statement);
865 Statement_Required := False;
867 -- Loop_Statement with FOR and no label
869 when Tok_For =>
870 Check_Bad_Layout;
871 Append_To (Statement_List, P_For_Statement);
872 Statement_Required := False;
874 -- Goto_Statement
876 when Tok_Goto =>
877 Check_Bad_Layout;
878 Append_To (Statement_List, P_Goto_Statement);
879 Statement_Required := False;
881 -- If_Statement
883 when Tok_If =>
884 Check_Bad_Layout;
885 Append_To (Statement_List, P_If_Statement);
886 Statement_Required := False;
888 -- Loop_Statement
890 when Tok_Loop =>
891 Check_Bad_Layout;
892 Append_To (Statement_List, P_Loop_Statement);
893 Statement_Required := False;
895 -- Null_Statement
897 when Tok_Null =>
898 Check_Bad_Layout;
899 Append_To (Statement_List, P_Null_Statement);
900 Statement_Required := False;
902 -- Raise_Statement
904 when Tok_Raise =>
905 Check_Bad_Layout;
906 Append_To (Statement_List, P_Raise_Statement);
907 Statement_Required := False;
909 -- Requeue_Statement
911 when Tok_Requeue =>
912 Check_Bad_Layout;
913 Append_To (Statement_List, P_Requeue_Statement);
914 Statement_Required := False;
916 -- Return_Statement
918 when Tok_Return =>
919 Check_Bad_Layout;
920 Append_To (Statement_List, P_Return_Statement);
921 Statement_Required := False;
923 -- Select_Statement
925 when Tok_Select =>
926 Check_Bad_Layout;
927 Append_To (Statement_List, P_Select_Statement);
928 Statement_Required := False;
930 -- While_Statement (Block_Statement with while and no loop)
932 when Tok_While =>
933 Check_Bad_Layout;
934 Append_To (Statement_List, P_While_Statement);
935 Statement_Required := False;
937 -- Anything else is some kind of junk, signal an error message
938 -- and then raise Error_Resync, to merge with the normal
939 -- handling of a bad statement.
941 when others =>
943 if Token in Token_Class_Declk then
944 Junk_Declaration;
946 else
947 Error_Msg_BC -- CODEFIX
948 ("statement expected");
949 raise Error_Resync;
950 end if;
951 end case;
953 -- On error resynchronization, skip past next semicolon, and, since
954 -- we are still in the statement loop, look for next statement. We
955 -- set Statement_Required False to avoid an unnecessary error message
956 -- complaining that no statement was found (i.e. we consider the
957 -- junk to satisfy the requirement for a statement being present).
959 exception
960 when Error_Resync =>
961 Resync_Past_Semicolon_Or_To_Loop_Or_Then;
962 Statement_Required := False;
963 end;
965 exit when SS_Flags.Unco;
967 end loop;
969 return Statement_List;
971 end P_Sequence_Of_Statements;
973 --------------------
974 -- 5.1 Statement --
975 --------------------
977 ---------------------------
978 -- 5.1 Simple Statement --
979 ---------------------------
981 -- Parsed by P_Sequence_Of_Statements (5.1)
983 -----------------------------
984 -- 5.1 Compound Statement --
985 -----------------------------
987 -- Parsed by P_Sequence_Of_Statements (5.1)
989 -------------------------
990 -- 5.1 Null Statement --
991 -------------------------
993 -- NULL_STATEMENT ::= null;
995 -- The caller has already checked that the current token is null
997 -- Error recovery: cannot raise Error_Resync
999 function P_Null_Statement return Node_Id is
1000 Null_Stmt_Node : Node_Id;
1002 begin
1003 Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr);
1004 Scan; -- past NULL
1005 TF_Semicolon;
1006 return Null_Stmt_Node;
1007 end P_Null_Statement;
1009 ----------------
1010 -- 5.1 Label --
1011 ----------------
1013 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
1015 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
1017 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
1018 -- (not an OPERATOR_SYMBOL)
1020 -- The caller has already checked that the current token is <<
1022 -- Error recovery: can raise Error_Resync
1024 function P_Label return Node_Id is
1025 Label_Node : Node_Id;
1027 begin
1028 Label_Node := New_Node (N_Label, Token_Ptr);
1029 Scan; -- past <<
1030 Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
1031 T_Greater_Greater;
1032 Append_Elmt (Label_Node, Label_List);
1033 return Label_Node;
1034 end P_Label;
1036 -------------------------------
1037 -- 5.1 Statement Identifier --
1038 -------------------------------
1040 -- Statement label is parsed by P_Label (5.1)
1042 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1043 -- or P_While_Statement (5.5)
1045 -- Block label is parsed by P_Begin_Statement (5.6) or
1046 -- P_Declare_Statement (5.6)
1048 -------------------------------
1049 -- 5.2 Assignment Statement --
1050 -------------------------------
1052 -- ASSIGNMENT_STATEMENT ::=
1053 -- variable_NAME := EXPRESSION;
1055 -- Error recovery: can raise Error_Resync
1057 function P_Assignment_Statement (LHS : Node_Id) return Node_Id is
1058 Assign_Node : Node_Id;
1060 begin
1061 Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr);
1062 Set_Name (Assign_Node, LHS);
1063 Set_Expression (Assign_Node, P_Expression_No_Right_Paren);
1064 TF_Semicolon;
1065 return Assign_Node;
1066 end P_Assignment_Statement;
1068 -----------------------
1069 -- 5.3 If Statement --
1070 -----------------------
1072 -- IF_STATEMENT ::=
1073 -- if CONDITION then
1074 -- SEQUENCE_OF_STATEMENTS
1075 -- {elsif CONDITION then
1076 -- SEQUENCE_OF_STATEMENTS}
1077 -- [else
1078 -- SEQUENCE_OF_STATEMENTS]
1079 -- end if;
1081 -- The caller has checked that the initial token is IF (or in the error
1082 -- case of a mysterious THEN, the initial token may simply be THEN, in
1083 -- which case, no condition (or IF) was scanned).
1085 -- Error recovery: can raise Error_Resync
1087 function P_If_Statement return Node_Id is
1088 If_Node : Node_Id;
1089 Elsif_Node : Node_Id;
1090 Loc : Source_Ptr;
1092 procedure Add_Elsif_Part;
1093 -- An internal procedure used to scan out a single ELSIF part. On entry
1094 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1095 -- scanned out and is in Prev_Token.
1097 procedure Check_If_Column;
1098 -- An internal procedure used to check that THEN, ELSE, or ELSIF
1099 -- appear in the right place if column checking is enabled (i.e. if
1100 -- they are the first token on the line, then they must appear in
1101 -- the same column as the opening IF).
1103 procedure Check_Then_Column;
1104 -- This procedure carries out the style checks for a THEN token
1105 -- Note that the caller has set Loc to the Source_Ptr value for
1106 -- the previous IF or ELSIF token. These checks apply only to a
1107 -- THEN at the start of a line.
1109 function Else_Should_Be_Elsif return Boolean;
1110 -- An internal routine used to do a special error recovery check when
1111 -- an ELSE is encountered. It determines if the ELSE should be treated
1112 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1113 -- is followed by a sequence of tokens, starting on the same line as
1114 -- the ELSE, which are not expression terminators, followed by a THEN.
1115 -- On entry, the ELSE has been scanned out.
1117 procedure Add_Elsif_Part is
1118 begin
1119 if No (Elsif_Parts (If_Node)) then
1120 Set_Elsif_Parts (If_Node, New_List);
1121 end if;
1123 Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr);
1124 Loc := Prev_Token_Ptr;
1125 Set_Condition (Elsif_Node, P_Condition);
1126 Check_Then_Column;
1127 Then_Scan;
1128 Set_Then_Statements
1129 (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1130 Append (Elsif_Node, Elsif_Parts (If_Node));
1131 end Add_Elsif_Part;
1133 procedure Check_If_Column is
1134 begin
1135 if RM_Column_Check and then Token_Is_At_Start_Of_Line
1136 and then Start_Column /= Scope.Table (Scope.Last).Ecol
1137 then
1138 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
1139 Error_Msg_SC ("(style) this token should be@");
1140 end if;
1141 end Check_If_Column;
1143 procedure Check_Then_Column is
1144 begin
1145 if Token_Is_At_Start_Of_Line and then Token = Tok_Then then
1146 Check_If_Column;
1148 if Style_Check then
1149 Style.Check_Then (Loc);
1150 end if;
1151 end if;
1152 end Check_Then_Column;
1154 function Else_Should_Be_Elsif return Boolean is
1155 Scan_State : Saved_Scan_State;
1157 begin
1158 if Token_Is_At_Start_Of_Line then
1159 return False;
1161 else
1162 Save_Scan_State (Scan_State);
1164 loop
1165 if Token in Token_Class_Eterm then
1166 Restore_Scan_State (Scan_State);
1167 return False;
1168 else
1169 Scan; -- past non-expression terminating token
1171 if Token = Tok_Then then
1172 Restore_Scan_State (Scan_State);
1173 return True;
1174 end if;
1175 end if;
1176 end loop;
1177 end if;
1178 end Else_Should_Be_Elsif;
1180 -- Start of processing for P_If_Statement
1182 begin
1183 If_Node := New_Node (N_If_Statement, Token_Ptr);
1185 Push_Scope_Stack;
1186 Scope.Table (Scope.Last).Etyp := E_If;
1187 Scope.Table (Scope.Last).Ecol := Start_Column;
1188 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1189 Scope.Table (Scope.Last).Labl := Error;
1190 Scope.Table (Scope.Last).Node := If_Node;
1192 if Token = Tok_If then
1193 Loc := Token_Ptr;
1194 Scan; -- past IF
1195 Set_Condition (If_Node, P_Condition);
1197 -- Deal with misuse of IF expression => used instead
1198 -- of WHEN expression =>
1200 if Token = Tok_Arrow then
1201 Error_Msg_SC -- CODEFIX
1202 ("THEN expected");
1203 Scan; -- past the arrow
1204 Pop_Scope_Stack; -- remove unneeded entry
1205 raise Error_Resync;
1206 end if;
1208 Check_Then_Column;
1210 else
1211 Error_Msg_SC ("no IF for this THEN");
1212 Set_Condition (If_Node, Error);
1213 end if;
1215 Then_Scan;
1217 Set_Then_Statements
1218 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1220 -- This loop scans out else and elsif parts
1222 loop
1223 if Token = Tok_Elsif then
1224 Check_If_Column;
1226 if Present (Else_Statements (If_Node)) then
1227 Error_Msg_SP ("ELSIF cannot appear after ELSE");
1228 end if;
1230 Scan; -- past ELSIF
1231 Add_Elsif_Part;
1233 elsif Token = Tok_Else then
1234 Check_If_Column;
1235 Scan; -- past ELSE
1237 if Else_Should_Be_Elsif then
1238 Error_Msg_SP -- CODEFIX
1239 ("ELSE should be ELSIF");
1240 Add_Elsif_Part;
1242 else
1243 -- Here we have an else that really is an else
1245 if Present (Else_Statements (If_Node)) then
1246 Error_Msg_SP ("only one ELSE part allowed");
1247 Append_List
1248 (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
1249 Else_Statements (If_Node));
1250 else
1251 Set_Else_Statements
1252 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1253 end if;
1254 end if;
1256 -- If anything other than ELSE or ELSIF, exit the loop. The token
1257 -- had better be END (and in fact it had better be END IF), but
1258 -- we will let End_Statements take care of checking that.
1260 else
1261 exit;
1262 end if;
1263 end loop;
1265 End_Statements;
1266 return If_Node;
1268 end P_If_Statement;
1270 --------------------
1271 -- 5.3 Condition --
1272 --------------------
1274 -- CONDITION ::= boolean_EXPRESSION
1276 function P_Condition return Node_Id is
1277 begin
1278 return P_Condition (P_Expression_No_Right_Paren);
1279 end P_Condition;
1281 function P_Condition (Cond : Node_Id) return Node_Id is
1282 begin
1283 -- It is never possible for := to follow a condition, so if we get
1284 -- a := we assume it is a mistyped equality. Note that we do not try
1285 -- to reconstruct the tree correctly in this case, but we do at least
1286 -- give an accurate error message.
1288 if Token = Tok_Colon_Equal then
1289 while Token = Tok_Colon_Equal loop
1290 Error_Msg_SC -- CODEFIX
1291 (""":="" should be ""=""");
1292 Scan; -- past junk :=
1293 Discard_Junk_Node (P_Expression_No_Right_Paren);
1294 end loop;
1296 return Cond;
1298 -- Otherwise check for redundant parentheses
1300 -- If the condition is a conditional or a quantified expression, it is
1301 -- parenthesized in the context of a condition, because of a separate
1302 -- syntax rule.
1304 else
1305 if Style_Check and then Paren_Count (Cond) > 0 then
1306 if not Nkind_In (Cond, N_If_Expression,
1307 N_Case_Expression,
1308 N_Quantified_Expression)
1309 or else Paren_Count (Cond) > 1
1310 then
1311 Style.Check_Xtra_Parens (First_Sloc (Cond));
1312 end if;
1313 end if;
1315 -- And return the result
1317 return Cond;
1318 end if;
1319 end P_Condition;
1321 -------------------------
1322 -- 5.4 Case Statement --
1323 -------------------------
1325 -- CASE_STATEMENT ::=
1326 -- case EXPRESSION is
1327 -- CASE_STATEMENT_ALTERNATIVE
1328 -- {CASE_STATEMENT_ALTERNATIVE}
1329 -- end case;
1331 -- The caller has checked that the first token is CASE
1333 -- Can raise Error_Resync
1335 function P_Case_Statement return Node_Id is
1336 Case_Node : Node_Id;
1337 Alternatives_List : List_Id;
1338 First_When_Loc : Source_Ptr;
1340 begin
1341 Case_Node := New_Node (N_Case_Statement, Token_Ptr);
1343 Push_Scope_Stack;
1344 Scope.Table (Scope.Last).Etyp := E_Case;
1345 Scope.Table (Scope.Last).Ecol := Start_Column;
1346 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1347 Scope.Table (Scope.Last).Labl := Error;
1348 Scope.Table (Scope.Last).Node := Case_Node;
1350 Scan; -- past CASE
1351 Set_Expression (Case_Node, P_Expression_No_Right_Paren);
1352 TF_Is;
1354 -- Prepare to parse case statement alternatives
1356 Alternatives_List := New_List;
1357 P_Pragmas_Opt (Alternatives_List);
1358 First_When_Loc := Token_Ptr;
1360 -- Loop through case statement alternatives
1362 loop
1363 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1364 -- that it is a semantic check to ensure the proper use of OTHERS
1366 if Token = Tok_When or else Token = Tok_Others then
1367 Append (P_Case_Statement_Alternative, Alternatives_List);
1369 -- If we have an END, then probably we are at the end of the case
1370 -- but we only exit if Check_End thinks the END was reasonable.
1372 elsif Token = Tok_End then
1373 exit when Check_End;
1375 -- Here if token is other than WHEN, OTHERS or END. We definitely
1376 -- have an error, but the question is whether or not to get out of
1377 -- the case statement. We don't want to get out early, or we will
1378 -- get a slew of junk error messages for subsequent when tokens.
1380 -- If the token is not at the start of the line, or if it is indented
1381 -- with respect to the current case statement, then the best guess is
1382 -- that we are still supposed to be inside the case statement. We
1383 -- complain about the missing WHEN, and discard the junk statements.
1385 elsif not Token_Is_At_Start_Of_Line
1386 or else Start_Column > Scope.Table (Scope.Last).Ecol
1387 then
1388 Error_Msg_BC ("WHEN (case statement alternative) expected");
1390 -- Here is a possibility for infinite looping if we don't make
1391 -- progress. So try to process statements, otherwise exit
1393 declare
1394 Error_Ptr : constant Source_Ptr := Scan_Ptr;
1395 begin
1396 Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm));
1397 exit when Scan_Ptr = Error_Ptr and then Check_End;
1398 end;
1400 -- Here we have a junk token at the start of the line and it is
1401 -- not indented. If Check_End thinks there is a missing END, then
1402 -- we will get out of the case, otherwise we keep going.
1404 else
1405 exit when Check_End;
1406 end if;
1407 end loop;
1409 -- Make sure we have at least one alternative
1411 if No (First_Non_Pragma (Alternatives_List)) then
1412 Error_Msg
1413 ("WHEN expected, must have at least one alternative in case",
1414 First_When_Loc);
1415 return Error;
1417 else
1418 Set_Alternatives (Case_Node, Alternatives_List);
1419 return Case_Node;
1420 end if;
1421 end P_Case_Statement;
1423 -------------------------------------
1424 -- 5.4 Case Statement Alternative --
1425 -------------------------------------
1427 -- CASE_STATEMENT_ALTERNATIVE ::=
1428 -- when DISCRETE_CHOICE_LIST =>
1429 -- SEQUENCE_OF_STATEMENTS
1431 -- The caller has checked that the initial token is WHEN or OTHERS
1432 -- Error recovery: can raise Error_Resync
1434 function P_Case_Statement_Alternative return Node_Id is
1435 Case_Alt_Node : Node_Id;
1437 begin
1438 if Style_Check then
1439 Style.Check_Indentation;
1440 end if;
1442 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
1443 T_When; -- past WHEN (or give error in OTHERS case)
1444 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
1445 TF_Arrow;
1446 Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
1447 return Case_Alt_Node;
1448 end P_Case_Statement_Alternative;
1450 -------------------------
1451 -- 5.5 Loop Statement --
1452 -------------------------
1454 -- LOOP_STATEMENT ::=
1455 -- [LOOP_STATEMENT_IDENTIFIER:]
1456 -- [ITERATION_SCHEME] loop
1457 -- SEQUENCE_OF_STATEMENTS
1458 -- end loop [loop_IDENTIFIER];
1460 -- ITERATION_SCHEME ::=
1461 -- while CONDITION
1462 -- | for LOOP_PARAMETER_SPECIFICATION
1464 -- The parsing of loop statements is handled by one of three functions
1465 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1466 -- on the initial keyword in the construct (excluding the identifier)
1468 -- P_Loop_Statement
1470 -- This function parses the case where no iteration scheme is present
1472 -- The caller has checked that the initial token is LOOP. The parameter
1473 -- is the node identifiers for the loop label if any (or is set to Empty
1474 -- if there is no loop label).
1476 -- Error recovery : cannot raise Error_Resync
1478 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1479 Loop_Node : Node_Id;
1480 Created_Name : Node_Id;
1482 begin
1483 Push_Scope_Stack;
1484 Scope.Table (Scope.Last).Labl := Loop_Name;
1485 Scope.Table (Scope.Last).Ecol := Start_Column;
1486 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1487 Scope.Table (Scope.Last).Etyp := E_Loop;
1489 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1490 TF_Loop;
1492 if No (Loop_Name) then
1493 Created_Name :=
1494 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
1495 Set_Comes_From_Source (Created_Name, False);
1496 Set_Has_Created_Identifier (Loop_Node, True);
1497 Set_Identifier (Loop_Node, Created_Name);
1498 Scope.Table (Scope.Last).Labl := Created_Name;
1499 else
1500 Set_Identifier (Loop_Node, Loop_Name);
1501 end if;
1503 Append_Elmt (Loop_Node, Label_List);
1504 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1505 End_Statements (Loop_Node);
1506 return Loop_Node;
1507 end P_Loop_Statement;
1509 -- P_For_Statement
1511 -- This function parses a loop statement with a FOR iteration scheme
1513 -- The caller has checked that the initial token is FOR. The parameter
1514 -- is the node identifier for the block label if any (or is set to Empty
1515 -- if there is no block label).
1517 -- Note: the caller fills in the Identifier field if a label was present
1519 -- Error recovery: can raise Error_Resync
1521 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1522 Loop_Node : Node_Id;
1523 Iter_Scheme_Node : Node_Id;
1524 Loop_For_Flag : Boolean;
1525 Created_Name : Node_Id;
1526 Spec : Node_Id;
1528 begin
1529 Push_Scope_Stack;
1530 Scope.Table (Scope.Last).Labl := Loop_Name;
1531 Scope.Table (Scope.Last).Ecol := Start_Column;
1532 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1533 Scope.Table (Scope.Last).Etyp := E_Loop;
1535 Loop_For_Flag := (Prev_Token = Tok_Loop);
1536 Scan; -- past FOR
1537 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1538 Spec := P_Loop_Parameter_Specification;
1540 if Nkind (Spec) = N_Loop_Parameter_Specification then
1541 Set_Loop_Parameter_Specification (Iter_Scheme_Node, Spec);
1542 else
1543 Set_Iterator_Specification (Iter_Scheme_Node, Spec);
1544 end if;
1546 -- The following is a special test so that a miswritten for loop such
1547 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1548 -- entry in the scope stack. We don't bother to actually fix up the
1549 -- tree in this case since it's not worth the effort. Instead we just
1550 -- eat up the loop junk, leaving the entry for what now looks like an
1551 -- unmodified loop intact.
1553 if Loop_For_Flag and then Token = Tok_Semicolon then
1554 Error_Msg_SC ("LOOP belongs here, not before FOR");
1555 Pop_Scope_Stack;
1556 return Error;
1558 -- Normal case
1560 else
1561 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1563 if No (Loop_Name) then
1564 Created_Name :=
1565 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
1566 Set_Comes_From_Source (Created_Name, False);
1567 Set_Has_Created_Identifier (Loop_Node, True);
1568 Set_Identifier (Loop_Node, Created_Name);
1569 Scope.Table (Scope.Last).Labl := Created_Name;
1570 else
1571 Set_Identifier (Loop_Node, Loop_Name);
1572 end if;
1574 TF_Loop;
1575 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1576 End_Statements (Loop_Node);
1577 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1578 Append_Elmt (Loop_Node, Label_List);
1579 return Loop_Node;
1580 end if;
1581 end P_For_Statement;
1583 -- P_While_Statement
1585 -- This procedure scans a loop statement with a WHILE iteration scheme
1587 -- The caller has checked that the initial token is WHILE. The parameter
1588 -- is the node identifier for the block label if any (or is set to Empty
1589 -- if there is no block label).
1591 -- Error recovery: cannot raise Error_Resync
1593 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1594 Loop_Node : Node_Id;
1595 Iter_Scheme_Node : Node_Id;
1596 Loop_While_Flag : Boolean;
1597 Created_Name : Node_Id;
1599 begin
1600 Push_Scope_Stack;
1601 Scope.Table (Scope.Last).Labl := Loop_Name;
1602 Scope.Table (Scope.Last).Ecol := Start_Column;
1603 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1604 Scope.Table (Scope.Last).Etyp := E_Loop;
1606 Loop_While_Flag := (Prev_Token = Tok_Loop);
1607 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1608 Scan; -- past WHILE
1609 Set_Condition (Iter_Scheme_Node, P_Condition);
1611 -- The following is a special test so that a miswritten for loop such
1612 -- as "loop while I > 10;" is handled nicely, without making an extra
1613 -- entry in the scope stack. We don't bother to actually fix up the
1614 -- tree in this case since it's not worth the effort. Instead we just
1615 -- eat up the loop junk, leaving the entry for what now looks like an
1616 -- unmodified loop intact.
1618 if Loop_While_Flag and then Token = Tok_Semicolon then
1619 Error_Msg_SC ("LOOP belongs here, not before WHILE");
1620 Pop_Scope_Stack;
1621 return Error;
1623 -- Normal case
1625 else
1626 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1627 TF_Loop;
1629 if No (Loop_Name) then
1630 Created_Name :=
1631 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
1632 Set_Comes_From_Source (Created_Name, False);
1633 Set_Has_Created_Identifier (Loop_Node, True);
1634 Set_Identifier (Loop_Node, Created_Name);
1635 Scope.Table (Scope.Last).Labl := Created_Name;
1636 else
1637 Set_Identifier (Loop_Node, Loop_Name);
1638 end if;
1640 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1641 End_Statements (Loop_Node);
1642 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1643 Append_Elmt (Loop_Node, Label_List);
1644 return Loop_Node;
1645 end if;
1646 end P_While_Statement;
1648 ---------------------------------------
1649 -- 5.5 Loop Parameter Specification --
1650 ---------------------------------------
1652 -- LOOP_PARAMETER_SPECIFICATION ::=
1653 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1655 -- Error recovery: cannot raise Error_Resync
1657 function P_Loop_Parameter_Specification return Node_Id is
1658 Loop_Param_Specification_Node : Node_Id;
1660 ID_Node : Node_Id;
1661 Scan_State : Saved_Scan_State;
1663 begin
1665 Save_Scan_State (Scan_State);
1666 ID_Node := P_Defining_Identifier (C_In);
1668 -- If the next token is OF, it indicates an Ada 2012 iterator. If the
1669 -- next token is a colon, this is also an Ada 2012 iterator, including
1670 -- a subtype indication for the loop parameter. Otherwise we parse the
1671 -- construct as a loop parameter specification. Note that the form
1672 -- "for A in B" is ambiguous, and must be resolved semantically: if B
1673 -- is a discrete subtype this is a loop specification, but if it is an
1674 -- expression it is an iterator specification. Ambiguity is resolved
1675 -- during analysis of the loop parameter specification.
1677 if Token = Tok_Of or else Token = Tok_Colon then
1678 Error_Msg_Ada_2012_Feature ("iterator", Token_Ptr);
1679 return P_Iterator_Specification (ID_Node);
1680 end if;
1682 -- The span of the Loop_Parameter_Specification starts at the
1683 -- defining identifier.
1685 Loop_Param_Specification_Node :=
1686 New_Node (N_Loop_Parameter_Specification, Sloc (ID_Node));
1687 Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
1689 if Token = Tok_Left_Paren then
1690 Error_Msg_SC ("subscripted loop parameter not allowed");
1691 Restore_Scan_State (Scan_State);
1692 Discard_Junk_Node (P_Name);
1694 elsif Token = Tok_Dot then
1695 Error_Msg_SC ("selected loop parameter not allowed");
1696 Restore_Scan_State (Scan_State);
1697 Discard_Junk_Node (P_Name);
1698 end if;
1700 T_In;
1702 if Token = Tok_Reverse then
1703 Scan; -- past REVERSE
1704 Set_Reverse_Present (Loop_Param_Specification_Node, True);
1705 end if;
1707 Set_Discrete_Subtype_Definition
1708 (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
1709 return Loop_Param_Specification_Node;
1711 exception
1712 when Error_Resync =>
1713 return Error;
1714 end P_Loop_Parameter_Specification;
1716 ----------------------------------
1717 -- 5.5.1 Iterator_Specification --
1718 ----------------------------------
1720 function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id is
1721 Node1 : Node_Id;
1723 begin
1724 Node1 := New_Node (N_Iterator_Specification, Sloc (Def_Id));
1725 Set_Defining_Identifier (Node1, Def_Id);
1727 if Token = Tok_Colon then
1728 Scan; -- past :
1729 Set_Subtype_Indication (Node1, P_Subtype_Indication);
1730 end if;
1732 if Token = Tok_Of then
1733 Set_Of_Present (Node1);
1734 Scan; -- past OF
1736 elsif Token = Tok_In then
1737 Scan; -- past IN
1739 elsif Prev_Token = Tok_In
1740 and then Present (Subtype_Indication (Node1))
1741 then
1742 -- Simplest recovery is to transform it into an element iterator.
1743 -- Error message on 'in" has already been emitted when parsing the
1744 -- optional constraint.
1746 Set_Of_Present (Node1);
1747 Error_Msg_N
1748 ("subtype indication is only legal on an element iterator",
1749 Subtype_Indication (Node1));
1751 else
1752 return Error;
1753 end if;
1755 if Token = Tok_Reverse then
1756 Scan; -- past REVERSE
1757 Set_Reverse_Present (Node1, True);
1758 end if;
1760 Set_Name (Node1, P_Name);
1761 return Node1;
1762 end P_Iterator_Specification;
1764 --------------------------
1765 -- 5.6 Block Statement --
1766 --------------------------
1768 -- BLOCK_STATEMENT ::=
1769 -- [block_STATEMENT_IDENTIFIER:]
1770 -- [declare
1771 -- DECLARATIVE_PART]
1772 -- begin
1773 -- HANDLED_SEQUENCE_OF_STATEMENTS
1774 -- end [block_IDENTIFIER];
1776 -- The parsing of block statements is handled by one of the two functions
1777 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1778 -- a declare section is present
1780 -- P_Declare_Statement
1782 -- This function parses a block statement with DECLARE present
1784 -- The caller has checked that the initial token is DECLARE
1786 -- Error recovery: cannot raise Error_Resync
1788 function P_Declare_Statement
1789 (Block_Name : Node_Id := Empty)
1790 return Node_Id
1792 Block_Node : Node_Id;
1793 Created_Name : Node_Id;
1795 begin
1796 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1798 Push_Scope_Stack;
1799 Scope.Table (Scope.Last).Etyp := E_Name;
1800 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1801 Scope.Table (Scope.Last).Ecol := Start_Column;
1802 Scope.Table (Scope.Last).Labl := Block_Name;
1803 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1805 Scan; -- past DECLARE
1807 if No (Block_Name) then
1808 Created_Name :=
1809 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
1810 Set_Comes_From_Source (Created_Name, False);
1811 Set_Has_Created_Identifier (Block_Node, True);
1812 Set_Identifier (Block_Node, Created_Name);
1813 Scope.Table (Scope.Last).Labl := Created_Name;
1814 else
1815 Set_Identifier (Block_Node, Block_Name);
1816 end if;
1818 Append_Elmt (Block_Node, Label_List);
1819 Parse_Decls_Begin_End (Block_Node);
1820 return Block_Node;
1821 end P_Declare_Statement;
1823 -- P_Begin_Statement
1825 -- This function parses a block statement with no DECLARE present
1827 -- The caller has checked that the initial token is BEGIN
1829 -- Error recovery: cannot raise Error_Resync
1831 function P_Begin_Statement
1832 (Block_Name : Node_Id := Empty)
1833 return Node_Id
1835 Block_Node : Node_Id;
1836 Created_Name : Node_Id;
1838 begin
1839 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1841 Push_Scope_Stack;
1842 Scope.Table (Scope.Last).Etyp := E_Name;
1843 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1844 Scope.Table (Scope.Last).Ecol := Start_Column;
1845 Scope.Table (Scope.Last).Labl := Block_Name;
1846 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1848 if No (Block_Name) then
1849 Created_Name :=
1850 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
1851 Set_Comes_From_Source (Created_Name, False);
1852 Set_Has_Created_Identifier (Block_Node, True);
1853 Set_Identifier (Block_Node, Created_Name);
1854 Scope.Table (Scope.Last).Labl := Created_Name;
1855 else
1856 Set_Identifier (Block_Node, Block_Name);
1857 end if;
1859 Append_Elmt (Block_Node, Label_List);
1861 Scope.Table (Scope.Last).Ecol := Start_Column;
1862 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1863 Scan; -- past BEGIN
1864 Set_Handled_Statement_Sequence
1865 (Block_Node, P_Handled_Sequence_Of_Statements);
1866 End_Statements (Handled_Statement_Sequence (Block_Node));
1867 return Block_Node;
1868 end P_Begin_Statement;
1870 -------------------------
1871 -- 5.7 Exit Statement --
1872 -------------------------
1874 -- EXIT_STATEMENT ::=
1875 -- exit [loop_NAME] [when CONDITION];
1877 -- The caller has checked that the initial token is EXIT
1879 -- Error recovery: can raise Error_Resync
1881 function P_Exit_Statement return Node_Id is
1882 Exit_Node : Node_Id;
1884 function Missing_Semicolon_On_Exit return Boolean;
1885 -- This function deals with the following specialized situation
1887 -- when 'x' =>
1888 -- exit [identifier]
1889 -- when 'y' =>
1891 -- This looks like a messed up EXIT WHEN, when in fact the problem
1892 -- is a missing semicolon. It is called with Token pointing to the
1893 -- WHEN token, and returns True if a semicolon is missing before
1894 -- the WHEN as in the above example.
1896 -------------------------------
1897 -- Missing_Semicolon_On_Exit --
1898 -------------------------------
1900 function Missing_Semicolon_On_Exit return Boolean is
1901 State : Saved_Scan_State;
1903 begin
1904 if not Token_Is_At_Start_Of_Line then
1905 return False;
1907 elsif Scope.Table (Scope.Last).Etyp /= E_Case then
1908 return False;
1910 else
1911 Save_Scan_State (State);
1912 Scan; -- past WHEN
1913 Scan; -- past token after WHEN
1915 if Token = Tok_Arrow then
1916 Restore_Scan_State (State);
1917 return True;
1918 else
1919 Restore_Scan_State (State);
1920 return False;
1921 end if;
1922 end if;
1923 end Missing_Semicolon_On_Exit;
1925 -- Start of processing for P_Exit_Statement
1927 begin
1928 Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
1929 Scan; -- past EXIT
1931 if Token = Tok_Identifier then
1932 Set_Name (Exit_Node, P_Qualified_Simple_Name);
1934 elsif Style_Check then
1935 -- This EXIT has no name, so check that
1936 -- the innermost loop is unnamed too.
1938 Check_No_Exit_Name :
1939 for J in reverse 1 .. Scope.Last loop
1940 if Scope.Table (J).Etyp = E_Loop then
1941 if Present (Scope.Table (J).Labl)
1942 and then Comes_From_Source (Scope.Table (J).Labl)
1943 then
1944 -- Innermost loop in fact had a name, style check fails
1946 Style.No_Exit_Name (Scope.Table (J).Labl);
1947 end if;
1949 exit Check_No_Exit_Name;
1950 end if;
1951 end loop Check_No_Exit_Name;
1952 end if;
1954 if Token = Tok_When and then not Missing_Semicolon_On_Exit then
1955 Scan; -- past WHEN
1956 Set_Condition (Exit_Node, P_Condition);
1958 -- Allow IF instead of WHEN, giving error message
1960 elsif Token = Tok_If then
1961 T_When;
1962 Scan; -- past IF used in place of WHEN
1963 Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
1964 end if;
1966 TF_Semicolon;
1967 return Exit_Node;
1968 end P_Exit_Statement;
1970 -------------------------
1971 -- 5.8 Goto Statement --
1972 -------------------------
1974 -- GOTO_STATEMENT ::= goto label_NAME;
1976 -- The caller has checked that the initial token is GOTO (or TO in the
1977 -- error case where GO and TO were incorrectly separated).
1979 -- Error recovery: can raise Error_Resync
1981 function P_Goto_Statement return Node_Id is
1982 Goto_Node : Node_Id;
1984 begin
1985 Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
1986 Scan; -- past GOTO (or TO)
1987 Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
1988 Append_Elmt (Goto_Node, Goto_List);
1989 No_Constraint;
1990 TF_Semicolon;
1991 return Goto_Node;
1992 end P_Goto_Statement;
1994 ---------------------------
1995 -- Parse_Decls_Begin_End --
1996 ---------------------------
1998 -- This function parses the construct:
2000 -- DECLARATIVE_PART
2001 -- begin
2002 -- HANDLED_SEQUENCE_OF_STATEMENTS
2003 -- end [NAME];
2005 -- The caller has built the scope stack entry, and created the node to
2006 -- whose Declarations and Handled_Statement_Sequence fields are to be
2007 -- set. On return these fields are filled in (except in the case of a
2008 -- task body, where the handled statement sequence is optional, and may
2009 -- thus be Empty), and the scan is positioned past the End sequence.
2011 -- If the BEGIN is missing, then the parent node is used to help construct
2012 -- an appropriate missing BEGIN message. Possibilities for the parent are:
2014 -- N_Block_Statement declare block
2015 -- N_Entry_Body entry body
2016 -- N_Package_Body package body (begin part optional)
2017 -- N_Subprogram_Body procedure or function body
2018 -- N_Task_Body task body
2020 -- Note: in the case of a block statement, there is definitely a DECLARE
2021 -- present (because a Begin statement without a DECLARE is handled by the
2022 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
2024 -- Error recovery: cannot raise Error_Resync
2026 procedure Parse_Decls_Begin_End (Parent : Node_Id) is
2027 Body_Decl : Node_Id;
2028 Decls : List_Id;
2029 Parent_Nkind : Node_Kind;
2030 Spec_Node : Node_Id;
2031 HSS : Node_Id;
2033 procedure Missing_Begin (Msg : String);
2034 -- Called to post a missing begin message. In the normal case this is
2035 -- posted at the start of the current token. A special case arises when
2036 -- P_Declarative_Items has previously found a missing begin, in which
2037 -- case we replace the original error message.
2039 procedure Set_Null_HSS (Parent : Node_Id);
2040 -- Construct an empty handled statement sequence and install in Parent
2041 -- Leaves HSS set to reference the newly constructed statement sequence.
2043 -------------------
2044 -- Missing_Begin --
2045 -------------------
2047 procedure Missing_Begin (Msg : String) is
2048 begin
2049 if Missing_Begin_Msg = No_Error_Msg then
2050 Error_Msg_BC (Msg);
2051 else
2052 Change_Error_Text (Missing_Begin_Msg, Msg);
2054 -- Purge any messages issued after than, since a missing begin
2055 -- can cause a lot of havoc, and it is better not to dump these
2056 -- cascaded messages on the user.
2058 Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
2059 end if;
2060 end Missing_Begin;
2062 ------------------
2063 -- Set_Null_HSS --
2064 ------------------
2066 procedure Set_Null_HSS (Parent : Node_Id) is
2067 Null_Stm : Node_Id;
2069 begin
2070 Null_Stm :=
2071 Make_Null_Statement (Token_Ptr);
2072 Set_Comes_From_Source (Null_Stm, False);
2074 HSS :=
2075 Make_Handled_Sequence_Of_Statements (Token_Ptr,
2076 Statements => New_List (Null_Stm));
2077 Set_Comes_From_Source (HSS, False);
2079 Set_Handled_Statement_Sequence (Parent, HSS);
2080 end Set_Null_HSS;
2082 -- Start of processing for Parse_Decls_Begin_End
2084 begin
2085 Decls := P_Declarative_Part;
2087 if Ada_Version = Ada_83 then
2088 Check_Later_Vs_Basic_Declarations (Decls, During_Parsing => True);
2089 end if;
2091 -- Here is where we deal with the case of IS used instead of semicolon.
2092 -- Specifically, if the last declaration in the declarative part is a
2093 -- subprogram body still marked as having a bad IS, then this is where
2094 -- we decide that the IS should really have been a semicolon and that
2095 -- the body should have been a declaration. Note that if the bad IS
2096 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2097 -- then the Bad_Is_Detected flag would have been reset by now.
2099 Body_Decl := Last (Decls);
2101 if Present (Body_Decl)
2102 and then Nkind (Body_Decl) = N_Subprogram_Body
2103 and then Bad_Is_Detected (Body_Decl)
2104 then
2105 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2106 -- What we have now is a subprogram body with attached declarations
2107 -- and a possible statement sequence.
2109 -- First step is to take the declarations that were part of the bogus
2110 -- subprogram body and append them to the outer declaration chain.
2111 -- In other words we append them past the body (which we will later
2112 -- convert into a declaration).
2114 Append_List (Declarations (Body_Decl), Decls);
2116 -- Now take the handled statement sequence of the bogus body and
2117 -- set it as the statement sequence for the outer construct. Note
2118 -- that it may be empty (we specially allowed a missing BEGIN for
2119 -- a subprogram body marked as having a bad IS -- see below).
2121 Set_Handled_Statement_Sequence (Parent,
2122 Handled_Statement_Sequence (Body_Decl));
2124 -- Next step is to convert the old body node to a declaration node
2126 Spec_Node := Specification (Body_Decl);
2127 Change_Node (Body_Decl, N_Subprogram_Declaration);
2128 Set_Specification (Body_Decl, Spec_Node);
2130 -- Final step is to put the declarations for the parent where
2131 -- they belong, and then fall through the IF to scan out the
2132 -- END statements.
2134 Set_Declarations (Parent, Decls);
2136 -- This is the normal case (i.e. any case except the bad IS case)
2137 -- If we have a BEGIN, then scan out the sequence of statements, and
2138 -- also reset the expected column for the END to match the BEGIN.
2140 else
2141 Set_Declarations (Parent, Decls);
2143 if Token = Tok_Begin then
2144 if Style_Check then
2145 Style.Check_Indentation;
2146 end if;
2148 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
2150 if RM_Column_Check
2151 and then Token_Is_At_Start_Of_Line
2152 and then Start_Column /= Error_Msg_Col
2153 then
2154 Error_Msg_SC ("(style) BEGIN in wrong column, should be@");
2156 else
2157 Scope.Table (Scope.Last).Ecol := Start_Column;
2158 end if;
2160 Scope.Table (Scope.Last).Sloc := Token_Ptr;
2161 Scan; -- past BEGIN
2162 Set_Handled_Statement_Sequence (Parent,
2163 P_Handled_Sequence_Of_Statements);
2165 -- No BEGIN present
2167 else
2168 Parent_Nkind := Nkind (Parent);
2170 -- A special check for the missing IS case. If we have a
2171 -- subprogram body that was marked as having a suspicious
2172 -- IS, and the current token is END, then we simply confirm
2173 -- the suspicion, and do not require a BEGIN to be present
2175 if Parent_Nkind = N_Subprogram_Body
2176 and then Token = Tok_End
2177 and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is
2178 then
2179 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
2181 -- Otherwise BEGIN is not required for a package body, so we
2182 -- don't mind if it is missing, but we do construct a dummy
2183 -- one (so that we have somewhere to set End_Label).
2185 -- However if we have something other than a BEGIN which
2186 -- looks like it might be statements, then we signal a missing
2187 -- BEGIN for these cases as well. We define "something which
2188 -- looks like it might be statements" as a token other than
2189 -- END, EOF, or a token which starts declarations.
2191 elsif Parent_Nkind = N_Package_Body
2192 and then (Token = Tok_End
2193 or else Token = Tok_EOF
2194 or else Token in Token_Class_Declk)
2195 then
2196 Set_Null_HSS (Parent);
2198 -- These are cases in which a BEGIN is required and not present
2200 else
2201 Set_Null_HSS (Parent);
2203 -- Prepare to issue error message
2205 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
2206 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
2208 -- Now issue appropriate message
2210 if Parent_Nkind = N_Block_Statement then
2211 Missing_Begin ("missing BEGIN for DECLARE#!");
2213 elsif Parent_Nkind = N_Entry_Body then
2214 Missing_Begin ("missing BEGIN for ENTRY#!");
2216 elsif Parent_Nkind = N_Subprogram_Body then
2217 if Nkind (Specification (Parent))
2218 = N_Function_Specification
2219 then
2220 Missing_Begin ("missing BEGIN for function&#!");
2221 else
2222 Missing_Begin ("missing BEGIN for procedure&#!");
2223 end if;
2225 -- The case for package body arises only when
2226 -- we have possible statement junk present.
2228 elsif Parent_Nkind = N_Package_Body then
2229 Missing_Begin ("missing BEGIN for package body&#!");
2231 else
2232 pragma Assert (Parent_Nkind = N_Task_Body);
2233 Missing_Begin ("missing BEGIN for task body&#!");
2234 end if;
2236 -- Here we pick up the statements after the BEGIN that
2237 -- should have been present but was not. We don't insist
2238 -- on statements being present if P_Declarative_Part had
2239 -- already found a missing BEGIN, since it might have
2240 -- swallowed a lone statement into the declarative part.
2242 if Missing_Begin_Msg /= No_Error_Msg
2243 and then Token = Tok_End
2244 then
2245 null;
2246 else
2247 Set_Handled_Statement_Sequence (Parent,
2248 P_Handled_Sequence_Of_Statements);
2249 end if;
2250 end if;
2251 end if;
2252 end if;
2254 -- Here with declarations and handled statement sequence scanned
2256 if Present (Handled_Statement_Sequence (Parent)) then
2257 End_Statements (Handled_Statement_Sequence (Parent));
2258 else
2259 End_Statements;
2260 end if;
2262 -- We know that End_Statements removed an entry from the scope stack
2263 -- (because it is required to do so under all circumstances). We can
2264 -- therefore reference the entry it removed one past the stack top.
2265 -- What we are interested in is whether it was a case of a bad IS.
2267 if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
2268 Error_Msg -- CODEFIX
2269 ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
2270 Set_Bad_Is_Detected (Parent, True);
2271 end if;
2273 end Parse_Decls_Begin_End;
2275 -------------------------
2276 -- Set_Loop_Block_Name --
2277 -------------------------
2279 function Set_Loop_Block_Name (L : Character) return Name_Id is
2280 begin
2281 Name_Buffer (1) := L;
2282 Name_Buffer (2) := '_';
2283 Name_Len := 2;
2284 Loop_Block_Count := Loop_Block_Count + 1;
2285 Add_Nat_To_Name_Buffer (Loop_Block_Count);
2286 return Name_Find;
2287 end Set_Loop_Block_Name;
2289 ---------------
2290 -- Then_Scan --
2291 ---------------
2293 procedure Then_Scan is
2294 begin
2295 TF_Then;
2297 while Token = Tok_Then loop
2298 Error_Msg_SC -- CODEFIX
2299 ("redundant THEN");
2300 TF_Then;
2301 end loop;
2303 if Token = Tok_And or else Token = Tok_Or then
2304 Error_Msg_SC ("unexpected logical operator");
2305 Scan; -- past logical operator
2307 if (Prev_Token = Tok_And and then Token = Tok_Then)
2308 or else
2309 (Prev_Token = Tok_Or and then Token = Tok_Else)
2310 then
2311 Scan;
2312 end if;
2314 Discard_Junk_Node (P_Expression);
2315 end if;
2317 if Token = Tok_Then then
2318 Scan;
2319 end if;
2320 end Then_Scan;
2322 end Ch5;