PR sanitizer/80403
[official-gcc.git] / gcc / ada / par-ch5.adb
blob5d8b45ceae523044987332e5f019e65623b39e02
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-2016, 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 -- This Ada 2012 construct not allowed in a compiler unit
245 Check_Compiler_Unit ("null statement list", Token_Ptr);
247 declare
248 Null_Stm : constant Node_Id :=
249 Make_Null_Statement (Token_Ptr);
250 begin
251 Set_Comes_From_Source (Null_Stm, False);
252 Append_To (Statement_List, Null_Stm);
253 end;
255 -- If not Ada 2012, or not special case above, give error message
257 else
258 Error_Msg_BC -- CODEFIX
259 ("statement expected");
260 end if;
261 end if;
262 end Test_Statement_Required;
264 -- Start of processing for P_Sequence_Of_Statements
266 begin
267 Statement_List := New_List;
268 Statement_Required := SS_Flags.Sreq;
269 Statement_Seen := False;
271 loop
272 Ignore (Tok_Semicolon);
274 begin
275 if Style_Check then
276 Style.Check_Indentation;
277 end if;
279 -- Deal with reserved identifier (in assignment or call)
281 if Is_Reserved_Identifier then
282 Save_Scan_State (Scan_State); -- at possible bad identifier
283 Scan; -- and scan past it
285 -- We have an reserved word which is spelled in identifier
286 -- style, so the question is whether it really is intended
287 -- to be an identifier.
290 -- If followed by a semicolon, then it is an identifier,
291 -- with the exception of the cases tested for below.
293 (Token = Tok_Semicolon
294 and then Prev_Token /= Tok_Return
295 and then Prev_Token /= Tok_Null
296 and then Prev_Token /= Tok_Raise
297 and then Prev_Token /= Tok_End
298 and then Prev_Token /= Tok_Exit)
300 -- If followed by colon, colon-equal, or dot, then we
301 -- definitely have an identifier (could not be reserved)
303 or else Token = Tok_Colon
304 or else Token = Tok_Colon_Equal
305 or else Token = Tok_Dot
307 -- Left paren means we have an identifier except for those
308 -- reserved words that can legitimately be followed by a
309 -- left paren.
311 or else
312 (Token = Tok_Left_Paren
313 and then Prev_Token /= Tok_Case
314 and then Prev_Token /= Tok_Delay
315 and then Prev_Token /= Tok_If
316 and then Prev_Token /= Tok_Elsif
317 and then Prev_Token /= Tok_Return
318 and then Prev_Token /= Tok_When
319 and then Prev_Token /= Tok_While
320 and then Prev_Token /= Tok_Separate)
321 then
322 -- Here we have an apparent reserved identifier and the
323 -- token past it is appropriate to this usage (and would
324 -- be a definite error if this is not an identifier). What
325 -- we do is to use P_Identifier to fix up the identifier,
326 -- and then fall into the normal processing.
328 Restore_Scan_State (Scan_State); -- back to the ID
329 Scan_Reserved_Identifier (Force_Msg => False);
331 -- Not a reserved identifier after all (or at least we can't
332 -- be sure that it is), so reset the scan and continue.
334 else
335 Restore_Scan_State (Scan_State); -- back to the reserved word
336 end if;
337 end if;
339 -- Now look to see what kind of statement we have
341 case Token is
343 -- Case of end or EOF
345 when Tok_End
346 | Tok_EOF
348 -- These tokens always terminate the statement sequence
350 Test_Statement_Required;
351 exit;
353 -- Case of ELSIF
355 when Tok_Elsif =>
357 -- Terminate if Eftm set or if the ELSIF is to the left
358 -- of the expected column of the end for this sequence
360 if SS_Flags.Eftm
361 or else Start_Column < Scope.Table (Scope.Last).Ecol
362 then
363 Test_Statement_Required;
364 exit;
366 -- Otherwise complain and skip past ELSIF Condition then
368 else
369 Error_Msg_SC ("ELSIF not allowed here");
370 Scan; -- past ELSIF
371 Discard_Junk_Node (P_Expression_No_Right_Paren);
372 Then_Scan;
373 Statement_Required := False;
374 end if;
376 -- Case of ELSE
378 when Tok_Else =>
380 -- Terminate if Eltm set or if the else is to the left
381 -- of the expected column of the end for this sequence
383 if SS_Flags.Eltm
384 or else Start_Column < Scope.Table (Scope.Last).Ecol
385 then
386 Test_Statement_Required;
387 exit;
389 -- Otherwise complain and skip past else
391 else
392 Error_Msg_SC ("ELSE not allowed here");
393 Scan; -- past ELSE
394 Statement_Required := False;
395 end if;
397 -- Case of exception
399 when Tok_Exception =>
400 Test_Statement_Required;
402 -- If Extm not set and the exception is not to the left of
403 -- the expected column of the end for this sequence, then we
404 -- assume it belongs to the current sequence, even though it
405 -- is not permitted.
407 if not SS_Flags.Extm and then
408 Start_Column >= Scope.Table (Scope.Last).Ecol
410 then
411 Error_Msg_SC ("exception handler not permitted here");
412 Scan; -- past EXCEPTION
413 Discard_Junk_List (Parse_Exception_Handlers);
414 end if;
416 -- Always return, in the case where we scanned out handlers
417 -- that we did not expect, Parse_Exception_Handlers returned
418 -- with Token being either end or EOF, so we are OK.
420 exit;
422 -- Case of OR
424 when Tok_Or =>
426 -- Terminate if Ortm set or if the or is to the left of the
427 -- expected column of the end for this sequence.
429 if SS_Flags.Ortm
430 or else Start_Column < Scope.Table (Scope.Last).Ecol
431 then
432 Test_Statement_Required;
433 exit;
435 -- Otherwise complain and skip past or
437 else
438 Error_Msg_SC ("OR not allowed here");
439 Scan; -- past or
440 Statement_Required := False;
441 end if;
443 -- Case of THEN (deal also with THEN ABORT)
445 when Tok_Then =>
446 Save_Scan_State (Scan_State); -- at THEN
447 Scan; -- past THEN
449 -- Terminate if THEN ABORT allowed (ATC case)
451 exit when SS_Flags.Tatm and then Token = Tok_Abort;
453 -- Otherwise we treat THEN as some kind of mess where we did
454 -- not see the associated IF, but we pick up assuming it had
455 -- been there.
457 Restore_Scan_State (Scan_State); -- to THEN
458 Append_To (Statement_List, P_If_Statement);
459 Statement_Required := False;
461 -- Case of WHEN (error because we are not in a case)
463 when Tok_Others
464 | Tok_When
466 -- Terminate if Whtm set or if the WHEN is to the left of
467 -- the expected column of the end for this sequence.
469 if SS_Flags.Whtm
470 or else Start_Column < Scope.Table (Scope.Last).Ecol
471 then
472 Test_Statement_Required;
473 exit;
475 -- Otherwise complain and skip when Choice {| Choice} =>
477 else
478 Error_Msg_SC ("WHEN not allowed here");
479 Scan; -- past when
480 Discard_Junk_List (P_Discrete_Choice_List);
481 TF_Arrow;
482 Statement_Required := False;
483 end if;
485 -- Cases of statements starting with an identifier
487 when Tok_Identifier =>
488 Check_Bad_Layout;
490 -- Save scan pointers and line number in case block label
492 Id_Node := Token_Node;
493 Block_Label := Token_Name;
494 Save_Scan_State (Scan_State_Label); -- at possible label
495 Scan; -- past Id
497 -- Check for common case of assignment, since it occurs
498 -- frequently, and we want to process it efficiently.
500 if Token = Tok_Colon_Equal then
501 Scan; -- past the colon-equal
502 Append_To (Statement_List,
503 P_Assignment_Statement (Id_Node));
504 Statement_Required := False;
506 -- Check common case of procedure call, another case that
507 -- we want to speed up as much as possible.
509 elsif Token = Tok_Semicolon then
510 Change_Name_To_Procedure_Call_Statement (Id_Node);
511 Append_To (Statement_List, Id_Node);
512 Scan; -- past semicolon
513 Statement_Required := False;
515 -- Here is the special test for a suspicious label, more
516 -- accurately a suspicious name, which we think perhaps
517 -- should have been a label. If next token is one of
518 -- LOOP, FOR, WHILE, DECLARE, BEGIN, then make an entry
519 -- in the suspicious label table.
521 if Token = Tok_Loop or else
522 Token = Tok_For or else
523 Token = Tok_While or else
524 Token = Tok_Declare or else
525 Token = Tok_Begin
526 then
527 Suspicious_Labels.Append
528 ((Proc_Call => Id_Node,
529 Semicolon_Loc => Prev_Token_Ptr,
530 Start_Token => Token_Ptr));
531 end if;
533 -- Check for case of "go to" in place of "goto"
535 elsif Token = Tok_Identifier
536 and then Block_Label = Name_Go
537 and then Token_Name = Name_To
538 then
539 Error_Msg_SP -- CODEFIX
540 ("goto is one word");
541 Append_To (Statement_List, P_Goto_Statement);
542 Statement_Required := False;
544 -- Check common case of = used instead of :=, just so we
545 -- give a better error message for this special misuse.
547 elsif Token = Tok_Equal then
548 T_Colon_Equal; -- give := expected message
549 Append_To (Statement_List,
550 P_Assignment_Statement (Id_Node));
551 Statement_Required := False;
553 -- Check case of loop label or block label
555 elsif Token = Tok_Colon
556 or else (Token in Token_Class_Labeled_Stmt
557 and then not Token_Is_At_Start_Of_Line)
558 then
559 T_Colon; -- past colon (if there, or msg for missing one)
561 -- Test for more than one label
563 loop
564 exit when Token /= Tok_Identifier;
565 Save_Scan_State (Scan_State); -- at second Id
566 Scan; -- past Id
568 if Token = Tok_Colon then
569 Error_Msg_SP
570 ("only one label allowed on block or loop");
571 Scan; -- past colon on extra label
573 -- Use the second label as the "real" label
575 Scan_State_Label := Scan_State;
577 -- We will set Error_name as the Block_Label since
578 -- we really don't know which of the labels might
579 -- be used at the end of the loop or block.
581 Block_Label := Error_Name;
583 -- If Id with no colon, then backup to point to the
584 -- Id and we will issue the message below when we try
585 -- to scan out the statement as some other form.
587 else
588 Restore_Scan_State (Scan_State); -- to second Id
589 exit;
590 end if;
591 end loop;
593 -- Loop_Statement (labeled Loop_Statement)
595 if Token = Tok_Loop then
596 Append_To (Statement_List,
597 P_Loop_Statement (Id_Node));
599 -- While statement (labeled loop statement with WHILE)
601 elsif Token = Tok_While then
602 Append_To (Statement_List,
603 P_While_Statement (Id_Node));
605 -- Declare statement (labeled block statement with
606 -- DECLARE part)
608 elsif Token = Tok_Declare then
609 Append_To (Statement_List,
610 P_Declare_Statement (Id_Node));
612 -- Begin statement (labeled block statement with no
613 -- DECLARE part)
615 elsif Token = Tok_Begin then
616 Append_To (Statement_List,
617 P_Begin_Statement (Id_Node));
619 -- For statement (labeled loop statement with FOR)
621 elsif Token = Tok_For then
622 Append_To (Statement_List,
623 P_For_Statement (Id_Node));
625 -- Improper statement follows label. If we have an
626 -- expression token, then assume the colon was part
627 -- of a misplaced declaration.
629 elsif Token not in Token_Class_Eterm then
630 Restore_Scan_State (Scan_State_Label);
631 Junk_Declaration;
633 -- Otherwise complain we have inappropriate statement
635 else
636 Error_Msg_AP
637 ("loop or block statement must follow label");
638 end if;
640 Statement_Required := False;
642 -- Here we have an identifier followed by something
643 -- other than a colon, semicolon or assignment symbol.
644 -- The only valid possibility is a name extension symbol
646 elsif Token in Token_Class_Namext then
647 Restore_Scan_State (Scan_State_Label); -- to Id
648 Name_Node := P_Name;
650 -- Skip junk right parens in this context
652 Ignore (Tok_Right_Paren);
654 -- Check context following call
656 if Token = Tok_Colon_Equal then
657 Scan; -- past colon equal
658 Append_To (Statement_List,
659 P_Assignment_Statement (Name_Node));
660 Statement_Required := False;
662 -- Check common case of = used instead of :=
664 elsif Token = Tok_Equal then
665 T_Colon_Equal; -- give := expected message
666 Append_To (Statement_List,
667 P_Assignment_Statement (Name_Node));
668 Statement_Required := False;
670 -- Check apostrophe cases
672 elsif Token = Tok_Apostrophe then
673 Append_To (Statement_List,
674 P_Code_Statement (Name_Node));
675 Statement_Required := False;
677 -- The only other valid item after a name is ; which
678 -- means that the item we just scanned was a call.
680 elsif Token = Tok_Semicolon then
681 Change_Name_To_Procedure_Call_Statement (Name_Node);
682 Append_To (Statement_List, Name_Node);
683 Scan; -- past semicolon
684 Statement_Required := False;
686 -- A slash following an identifier or a selected
687 -- component in this situation is most likely a period
688 -- (see location of keys on keyboard).
690 elsif Token = Tok_Slash
691 and then (Nkind (Name_Node) = N_Identifier
692 or else
693 Nkind (Name_Node) = N_Selected_Component)
694 then
695 Error_Msg_SC -- CODEFIX
696 ("""/"" should be "".""");
697 Statement_Required := False;
698 raise Error_Resync;
700 -- Else we have a missing semicolon
702 else
703 TF_Semicolon;
705 -- Normal processing as though semicolon were present
707 Change_Name_To_Procedure_Call_Statement (Name_Node);
708 Append_To (Statement_List, Name_Node);
709 Statement_Required := False;
710 end if;
712 -- If junk after identifier, check if identifier is an
713 -- instance of an incorrectly spelled keyword. If so, we
714 -- do nothing. The Bad_Spelling_Of will have reset Token
715 -- to the appropriate keyword, so the next time round the
716 -- loop we will process the modified token. Note that we
717 -- check for ELSIF before ELSE here. That's not accidental.
718 -- We don't want to identify a misspelling of ELSE as
719 -- ELSIF, and in particular we do not want to treat ELSEIF
720 -- as ELSE IF.
722 else
723 Restore_Scan_State (Scan_State_Label); -- to identifier
725 if Bad_Spelling_Of (Tok_Abort)
726 or else Bad_Spelling_Of (Tok_Accept)
727 or else Bad_Spelling_Of (Tok_Case)
728 or else Bad_Spelling_Of (Tok_Declare)
729 or else Bad_Spelling_Of (Tok_Delay)
730 or else Bad_Spelling_Of (Tok_Elsif)
731 or else Bad_Spelling_Of (Tok_Else)
732 or else Bad_Spelling_Of (Tok_End)
733 or else Bad_Spelling_Of (Tok_Exception)
734 or else Bad_Spelling_Of (Tok_Exit)
735 or else Bad_Spelling_Of (Tok_For)
736 or else Bad_Spelling_Of (Tok_Goto)
737 or else Bad_Spelling_Of (Tok_If)
738 or else Bad_Spelling_Of (Tok_Loop)
739 or else Bad_Spelling_Of (Tok_Or)
740 or else Bad_Spelling_Of (Tok_Pragma)
741 or else Bad_Spelling_Of (Tok_Raise)
742 or else Bad_Spelling_Of (Tok_Requeue)
743 or else Bad_Spelling_Of (Tok_Return)
744 or else Bad_Spelling_Of (Tok_Select)
745 or else Bad_Spelling_Of (Tok_When)
746 or else Bad_Spelling_Of (Tok_While)
747 then
748 null;
750 -- If not a bad spelling, then we really have junk
752 else
753 Scan; -- past identifier again
755 -- If next token is first token on line, then we
756 -- consider that we were missing a semicolon after
757 -- the identifier, and process it as a procedure
758 -- call with no parameters.
760 if Token_Is_At_Start_Of_Line then
761 Change_Name_To_Procedure_Call_Statement (Id_Node);
762 Append_To (Statement_List, Id_Node);
763 T_Semicolon; -- to give error message
764 Statement_Required := False;
766 -- Otherwise we give a missing := message and
767 -- simply abandon the junk that is there now.
769 else
770 T_Colon_Equal; -- give := expected message
771 raise Error_Resync;
772 end if;
774 end if;
775 end if;
777 -- Statement starting with operator symbol. This could be
778 -- a call, a name starting an assignment, or a qualified
779 -- expression.
781 when Tok_Operator_Symbol =>
782 Check_Bad_Layout;
783 Name_Node := P_Name;
785 -- An attempt at a range attribute or a qualified expression
786 -- must be illegal here (a code statement cannot possibly
787 -- allow qualification by a function name).
789 if Token = Tok_Apostrophe then
790 Error_Msg_SC ("apostrophe illegal here");
791 raise Error_Resync;
792 end if;
794 -- Scan possible assignment if we have a name
796 if Expr_Form = EF_Name
797 and then Token = Tok_Colon_Equal
798 then
799 Scan; -- past colon equal
800 Append_To (Statement_List,
801 P_Assignment_Statement (Name_Node));
802 else
803 Change_Name_To_Procedure_Call_Statement (Name_Node);
804 Append_To (Statement_List, Name_Node);
805 end if;
807 TF_Semicolon;
808 Statement_Required := False;
810 -- Label starting with << which must precede real statement
811 -- Note: in Ada 2012, the label may end the sequence.
813 when Tok_Less_Less =>
814 if Present (Last (Statement_List))
815 and then Nkind (Last (Statement_List)) /= N_Label
816 then
817 Statement_Seen := True;
818 end if;
820 Append_To (Statement_List, P_Label);
821 Statement_Required := True;
823 -- Pragma appearing as a statement in a statement sequence
825 when Tok_Pragma =>
826 Check_Bad_Layout;
827 Append_To (Statement_List, P_Pragma);
829 -- Abort_Statement
831 when Tok_Abort =>
832 Check_Bad_Layout;
833 Append_To (Statement_List, P_Abort_Statement);
834 Statement_Required := False;
836 -- Accept_Statement
838 when Tok_Accept =>
839 Check_Bad_Layout;
840 Append_To (Statement_List, P_Accept_Statement);
841 Statement_Required := False;
843 -- Begin_Statement (Block_Statement with no declare, no label)
845 when Tok_Begin =>
846 Check_Bad_Layout;
847 Append_To (Statement_List, P_Begin_Statement);
848 Statement_Required := False;
850 -- Case_Statement
852 when Tok_Case =>
853 Check_Bad_Layout;
854 Append_To (Statement_List, P_Case_Statement);
855 Statement_Required := False;
857 -- Block_Statement with DECLARE and no label
859 when Tok_Declare =>
860 Check_Bad_Layout;
861 Append_To (Statement_List, P_Declare_Statement);
862 Statement_Required := False;
864 -- Delay_Statement
866 when Tok_Delay =>
867 Check_Bad_Layout;
868 Append_To (Statement_List, P_Delay_Statement);
869 Statement_Required := False;
871 -- Exit_Statement
873 when Tok_Exit =>
874 Check_Bad_Layout;
875 Append_To (Statement_List, P_Exit_Statement);
876 Statement_Required := False;
878 -- Loop_Statement with FOR and no label
880 when Tok_For =>
881 Check_Bad_Layout;
882 Append_To (Statement_List, P_For_Statement);
883 Statement_Required := False;
885 -- Goto_Statement
887 when Tok_Goto =>
888 Check_Bad_Layout;
889 Append_To (Statement_List, P_Goto_Statement);
890 Statement_Required := False;
892 -- If_Statement
894 when Tok_If =>
895 Check_Bad_Layout;
896 Append_To (Statement_List, P_If_Statement);
897 Statement_Required := False;
899 -- Loop_Statement
901 when Tok_Loop =>
902 Check_Bad_Layout;
903 Append_To (Statement_List, P_Loop_Statement);
904 Statement_Required := False;
906 -- Null_Statement
908 when Tok_Null =>
909 Check_Bad_Layout;
910 Append_To (Statement_List, P_Null_Statement);
911 Statement_Required := False;
913 -- Raise_Statement
915 when Tok_Raise =>
916 Check_Bad_Layout;
917 Append_To (Statement_List, P_Raise_Statement);
918 Statement_Required := False;
920 -- Requeue_Statement
922 when Tok_Requeue =>
923 Check_Bad_Layout;
924 Append_To (Statement_List, P_Requeue_Statement);
925 Statement_Required := False;
927 -- Return_Statement
929 when Tok_Return =>
930 Check_Bad_Layout;
931 Append_To (Statement_List, P_Return_Statement);
932 Statement_Required := False;
934 -- Select_Statement
936 when Tok_Select =>
937 Check_Bad_Layout;
938 Append_To (Statement_List, P_Select_Statement);
939 Statement_Required := False;
941 -- While_Statement (Block_Statement with while and no loop)
943 when Tok_While =>
944 Check_Bad_Layout;
945 Append_To (Statement_List, P_While_Statement);
946 Statement_Required := False;
948 -- Anything else is some kind of junk, signal an error message
949 -- and then raise Error_Resync, to merge with the normal
950 -- handling of a bad statement.
952 when others =>
953 if Token in Token_Class_Declk then
954 Junk_Declaration;
956 else
957 Error_Msg_BC -- CODEFIX
958 ("statement expected");
959 raise Error_Resync;
960 end if;
961 end case;
963 -- On error resynchronization, skip past next semicolon, and, since
964 -- we are still in the statement loop, look for next statement. We
965 -- set Statement_Required False to avoid an unnecessary error message
966 -- complaining that no statement was found (i.e. we consider the
967 -- junk to satisfy the requirement for a statement being present).
969 exception
970 when Error_Resync =>
971 Resync_Past_Semicolon_Or_To_Loop_Or_Then;
972 Statement_Required := False;
973 end;
975 exit when SS_Flags.Unco;
976 end loop;
978 return Statement_List;
979 end P_Sequence_Of_Statements;
981 --------------------
982 -- 5.1 Statement --
983 --------------------
985 ---------------------------
986 -- 5.1 Simple Statement --
987 ---------------------------
989 -- Parsed by P_Sequence_Of_Statements (5.1)
991 -----------------------------
992 -- 5.1 Compound Statement --
993 -----------------------------
995 -- Parsed by P_Sequence_Of_Statements (5.1)
997 -------------------------
998 -- 5.1 Null Statement --
999 -------------------------
1001 -- NULL_STATEMENT ::= null;
1003 -- The caller has already checked that the current token is null
1005 -- Error recovery: cannot raise Error_Resync
1007 function P_Null_Statement return Node_Id is
1008 Null_Stmt_Node : Node_Id;
1010 begin
1011 Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr);
1012 Scan; -- past NULL
1013 TF_Semicolon;
1014 return Null_Stmt_Node;
1015 end P_Null_Statement;
1017 ----------------
1018 -- 5.1 Label --
1019 ----------------
1021 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
1023 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
1025 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
1026 -- (not an OPERATOR_SYMBOL)
1028 -- The caller has already checked that the current token is <<
1030 -- Error recovery: can raise Error_Resync
1032 function P_Label return Node_Id is
1033 Label_Node : Node_Id;
1035 begin
1036 Label_Node := New_Node (N_Label, Token_Ptr);
1037 Scan; -- past <<
1038 Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
1039 T_Greater_Greater;
1040 Append_Elmt (Label_Node, Label_List);
1041 return Label_Node;
1042 end P_Label;
1044 -------------------------------
1045 -- 5.1 Statement Identifier --
1046 -------------------------------
1048 -- Statement label is parsed by P_Label (5.1)
1050 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1051 -- or P_While_Statement (5.5)
1053 -- Block label is parsed by P_Begin_Statement (5.6) or
1054 -- P_Declare_Statement (5.6)
1056 -------------------------------
1057 -- 5.2 Assignment Statement --
1058 -------------------------------
1060 -- ASSIGNMENT_STATEMENT ::=
1061 -- variable_NAME := EXPRESSION;
1063 -- Error recovery: can raise Error_Resync
1065 function P_Assignment_Statement (LHS : Node_Id) return Node_Id is
1066 Assign_Node : Node_Id;
1068 begin
1069 Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr);
1070 Set_Name (Assign_Node, LHS);
1071 Set_Expression (Assign_Node, P_Expression_No_Right_Paren);
1072 TF_Semicolon;
1073 return Assign_Node;
1074 end P_Assignment_Statement;
1076 -----------------------
1077 -- 5.3 If Statement --
1078 -----------------------
1080 -- IF_STATEMENT ::=
1081 -- if CONDITION then
1082 -- SEQUENCE_OF_STATEMENTS
1083 -- {elsif CONDITION then
1084 -- SEQUENCE_OF_STATEMENTS}
1085 -- [else
1086 -- SEQUENCE_OF_STATEMENTS]
1087 -- end if;
1089 -- The caller has checked that the initial token is IF (or in the error
1090 -- case of a mysterious THEN, the initial token may simply be THEN, in
1091 -- which case, no condition (or IF) was scanned).
1093 -- Error recovery: can raise Error_Resync
1095 function P_If_Statement return Node_Id is
1096 If_Node : Node_Id;
1097 Elsif_Node : Node_Id;
1098 Loc : Source_Ptr;
1100 procedure Add_Elsif_Part;
1101 -- An internal procedure used to scan out a single ELSIF part. On entry
1102 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1103 -- scanned out and is in Prev_Token.
1105 procedure Check_If_Column;
1106 -- An internal procedure used to check that THEN, ELSE, or ELSIF
1107 -- appear in the right place if column checking is enabled (i.e. if
1108 -- they are the first token on the line, then they must appear in
1109 -- the same column as the opening IF).
1111 procedure Check_Then_Column;
1112 -- This procedure carries out the style checks for a THEN token
1113 -- Note that the caller has set Loc to the Source_Ptr value for
1114 -- the previous IF or ELSIF token.
1116 function Else_Should_Be_Elsif return Boolean;
1117 -- An internal routine used to do a special error recovery check when
1118 -- an ELSE is encountered. It determines if the ELSE should be treated
1119 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1120 -- is followed by a sequence of tokens, starting on the same line as
1121 -- the ELSE, which are not expression terminators, followed by a THEN.
1122 -- On entry, the ELSE has been scanned out.
1124 procedure Add_Elsif_Part is
1125 begin
1126 if No (Elsif_Parts (If_Node)) then
1127 Set_Elsif_Parts (If_Node, New_List);
1128 end if;
1130 Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr);
1131 Loc := Prev_Token_Ptr;
1132 Set_Condition (Elsif_Node, P_Condition);
1133 Check_Then_Column;
1134 Then_Scan;
1135 Set_Then_Statements
1136 (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1137 Append (Elsif_Node, Elsif_Parts (If_Node));
1138 end Add_Elsif_Part;
1140 procedure Check_If_Column is
1141 begin
1142 if RM_Column_Check and then Token_Is_At_Start_Of_Line
1143 and then Start_Column /= Scope.Table (Scope.Last).Ecol
1144 then
1145 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
1146 Error_Msg_SC ("(style) this token should be@");
1147 end if;
1148 end Check_If_Column;
1150 procedure Check_Then_Column is
1151 begin
1152 if Token = Tok_Then then
1153 Check_If_Column;
1155 if Style_Check then
1156 Style.Check_Then (Loc);
1157 end if;
1158 end if;
1159 end Check_Then_Column;
1161 function Else_Should_Be_Elsif return Boolean is
1162 Scan_State : Saved_Scan_State;
1164 begin
1165 if Token_Is_At_Start_Of_Line then
1166 return False;
1168 else
1169 Save_Scan_State (Scan_State);
1171 loop
1172 if Token in Token_Class_Eterm then
1173 Restore_Scan_State (Scan_State);
1174 return False;
1175 else
1176 Scan; -- past non-expression terminating token
1178 if Token = Tok_Then then
1179 Restore_Scan_State (Scan_State);
1180 return True;
1181 end if;
1182 end if;
1183 end loop;
1184 end if;
1185 end Else_Should_Be_Elsif;
1187 -- Start of processing for P_If_Statement
1189 begin
1190 If_Node := New_Node (N_If_Statement, Token_Ptr);
1192 Push_Scope_Stack;
1193 Scope.Table (Scope.Last).Etyp := E_If;
1194 Scope.Table (Scope.Last).Ecol := Start_Column;
1195 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1196 Scope.Table (Scope.Last).Labl := Error;
1197 Scope.Table (Scope.Last).Node := If_Node;
1199 if Token = Tok_If then
1200 Loc := Token_Ptr;
1201 Scan; -- past IF
1202 Set_Condition (If_Node, P_Condition);
1204 -- Deal with misuse of IF expression => used instead
1205 -- of WHEN expression =>
1207 if Token = Tok_Arrow then
1208 Error_Msg_SC -- CODEFIX
1209 ("THEN expected");
1210 Scan; -- past the arrow
1211 Pop_Scope_Stack; -- remove unneeded entry
1212 raise Error_Resync;
1213 end if;
1215 Check_Then_Column;
1217 else
1218 Error_Msg_SC ("no IF for this THEN");
1219 Set_Condition (If_Node, Error);
1220 end if;
1222 Then_Scan;
1224 Set_Then_Statements
1225 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1227 -- This loop scans out else and elsif parts
1229 loop
1230 if Token = Tok_Elsif then
1231 Check_If_Column;
1233 if Present (Else_Statements (If_Node)) then
1234 Error_Msg_SP ("ELSIF cannot appear after ELSE");
1235 end if;
1237 Scan; -- past ELSIF
1238 Add_Elsif_Part;
1240 elsif Token = Tok_Else then
1241 Check_If_Column;
1242 Scan; -- past ELSE
1244 if Else_Should_Be_Elsif then
1245 Error_Msg_SP -- CODEFIX
1246 ("ELSE should be ELSIF");
1247 Add_Elsif_Part;
1249 else
1250 -- Here we have an else that really is an else
1252 if Present (Else_Statements (If_Node)) then
1253 Error_Msg_SP ("only one ELSE part allowed");
1254 Append_List
1255 (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
1256 Else_Statements (If_Node));
1257 else
1258 Set_Else_Statements
1259 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1260 end if;
1261 end if;
1263 -- If anything other than ELSE or ELSIF, exit the loop. The token
1264 -- had better be END (and in fact it had better be END IF), but
1265 -- we will let End_Statements take care of checking that.
1267 else
1268 exit;
1269 end if;
1270 end loop;
1272 End_Statements;
1273 return If_Node;
1275 end P_If_Statement;
1277 --------------------
1278 -- 5.3 Condition --
1279 --------------------
1281 -- CONDITION ::= boolean_EXPRESSION
1283 function P_Condition return Node_Id is
1284 begin
1285 return P_Condition (P_Expression_No_Right_Paren);
1286 end P_Condition;
1288 function P_Condition (Cond : Node_Id) return Node_Id is
1289 begin
1290 -- It is never possible for := to follow a condition, so if we get
1291 -- a := we assume it is a mistyped equality. Note that we do not try
1292 -- to reconstruct the tree correctly in this case, but we do at least
1293 -- give an accurate error message.
1295 if Token = Tok_Colon_Equal then
1296 while Token = Tok_Colon_Equal loop
1297 Error_Msg_SC -- CODEFIX
1298 (""":="" should be ""=""");
1299 Scan; -- past junk :=
1300 Discard_Junk_Node (P_Expression_No_Right_Paren);
1301 end loop;
1303 return Cond;
1305 -- Otherwise check for redundant parentheses
1307 -- If the condition is a conditional or a quantified expression, it is
1308 -- parenthesized in the context of a condition, because of a separate
1309 -- syntax rule.
1311 else
1312 if Style_Check and then Paren_Count (Cond) > 0 then
1313 if not Nkind_In (Cond, N_If_Expression,
1314 N_Case_Expression,
1315 N_Quantified_Expression)
1316 or else Paren_Count (Cond) > 1
1317 then
1318 Style.Check_Xtra_Parens (First_Sloc (Cond));
1319 end if;
1320 end if;
1322 -- And return the result
1324 return Cond;
1325 end if;
1326 end P_Condition;
1328 -------------------------
1329 -- 5.4 Case Statement --
1330 -------------------------
1332 -- CASE_STATEMENT ::=
1333 -- case EXPRESSION is
1334 -- CASE_STATEMENT_ALTERNATIVE
1335 -- {CASE_STATEMENT_ALTERNATIVE}
1336 -- end case;
1338 -- The caller has checked that the first token is CASE
1340 -- Can raise Error_Resync
1342 function P_Case_Statement return Node_Id is
1343 Case_Node : Node_Id;
1344 Alternatives_List : List_Id;
1345 First_When_Loc : Source_Ptr;
1347 begin
1348 Case_Node := New_Node (N_Case_Statement, Token_Ptr);
1350 Push_Scope_Stack;
1351 Scope.Table (Scope.Last).Etyp := E_Case;
1352 Scope.Table (Scope.Last).Ecol := Start_Column;
1353 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1354 Scope.Table (Scope.Last).Labl := Error;
1355 Scope.Table (Scope.Last).Node := Case_Node;
1357 Scan; -- past CASE
1358 Set_Expression (Case_Node, P_Expression_No_Right_Paren);
1359 TF_Is;
1361 -- Prepare to parse case statement alternatives
1363 Alternatives_List := New_List;
1364 P_Pragmas_Opt (Alternatives_List);
1365 First_When_Loc := Token_Ptr;
1367 -- Loop through case statement alternatives
1369 loop
1370 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1371 -- that it is a semantic check to ensure the proper use of OTHERS
1373 if Token = Tok_When or else Token = Tok_Others then
1374 Append (P_Case_Statement_Alternative, Alternatives_List);
1376 -- If we have an END, then probably we are at the end of the case
1377 -- but we only exit if Check_End thinks the END was reasonable.
1379 elsif Token = Tok_End then
1380 exit when Check_End;
1382 -- Here if token is other than WHEN, OTHERS or END. We definitely
1383 -- have an error, but the question is whether or not to get out of
1384 -- the case statement. We don't want to get out early, or we will
1385 -- get a slew of junk error messages for subsequent when tokens.
1387 -- If the token is not at the start of the line, or if it is indented
1388 -- with respect to the current case statement, then the best guess is
1389 -- that we are still supposed to be inside the case statement. We
1390 -- complain about the missing WHEN, and discard the junk statements.
1392 elsif not Token_Is_At_Start_Of_Line
1393 or else Start_Column > Scope.Table (Scope.Last).Ecol
1394 then
1395 Error_Msg_BC ("WHEN (case statement alternative) expected");
1397 -- Here is a possibility for infinite looping if we don't make
1398 -- progress. So try to process statements, otherwise exit
1400 declare
1401 Error_Ptr : constant Source_Ptr := Scan_Ptr;
1402 begin
1403 Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm));
1404 exit when Scan_Ptr = Error_Ptr and then Check_End;
1405 end;
1407 -- Here we have a junk token at the start of the line and it is
1408 -- not indented. If Check_End thinks there is a missing END, then
1409 -- we will get out of the case, otherwise we keep going.
1411 else
1412 exit when Check_End;
1413 end if;
1414 end loop;
1416 -- Make sure we have at least one alternative
1418 if No (First_Non_Pragma (Alternatives_List)) then
1419 Error_Msg
1420 ("WHEN expected, must have at least one alternative in case",
1421 First_When_Loc);
1422 return Error;
1424 else
1425 Set_Alternatives (Case_Node, Alternatives_List);
1426 return Case_Node;
1427 end if;
1428 end P_Case_Statement;
1430 -------------------------------------
1431 -- 5.4 Case Statement Alternative --
1432 -------------------------------------
1434 -- CASE_STATEMENT_ALTERNATIVE ::=
1435 -- when DISCRETE_CHOICE_LIST =>
1436 -- SEQUENCE_OF_STATEMENTS
1438 -- The caller has checked that the initial token is WHEN or OTHERS
1439 -- Error recovery: can raise Error_Resync
1441 function P_Case_Statement_Alternative return Node_Id is
1442 Case_Alt_Node : Node_Id;
1444 begin
1445 if Style_Check then
1446 Style.Check_Indentation;
1447 end if;
1449 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
1450 T_When; -- past WHEN (or give error in OTHERS case)
1451 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
1452 TF_Arrow;
1453 Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
1454 return Case_Alt_Node;
1455 end P_Case_Statement_Alternative;
1457 -------------------------
1458 -- 5.5 Loop Statement --
1459 -------------------------
1461 -- LOOP_STATEMENT ::=
1462 -- [LOOP_STATEMENT_IDENTIFIER:]
1463 -- [ITERATION_SCHEME] loop
1464 -- SEQUENCE_OF_STATEMENTS
1465 -- end loop [loop_IDENTIFIER];
1467 -- ITERATION_SCHEME ::=
1468 -- while CONDITION
1469 -- | for LOOP_PARAMETER_SPECIFICATION
1471 -- The parsing of loop statements is handled by one of three functions
1472 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1473 -- on the initial keyword in the construct (excluding the identifier)
1475 -- P_Loop_Statement
1477 -- This function parses the case where no iteration scheme is present
1479 -- The caller has checked that the initial token is LOOP. The parameter
1480 -- is the node identifiers for the loop label if any (or is set to Empty
1481 -- if there is no loop label).
1483 -- Error recovery : cannot raise Error_Resync
1485 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1486 Loop_Node : Node_Id;
1487 Created_Name : Node_Id;
1489 begin
1490 Push_Scope_Stack;
1491 Scope.Table (Scope.Last).Labl := Loop_Name;
1492 Scope.Table (Scope.Last).Ecol := Start_Column;
1493 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1494 Scope.Table (Scope.Last).Etyp := E_Loop;
1496 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1497 TF_Loop;
1499 if No (Loop_Name) then
1500 Created_Name :=
1501 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
1502 Set_Comes_From_Source (Created_Name, False);
1503 Set_Has_Created_Identifier (Loop_Node, True);
1504 Set_Identifier (Loop_Node, Created_Name);
1505 Scope.Table (Scope.Last).Labl := Created_Name;
1506 else
1507 Set_Identifier (Loop_Node, Loop_Name);
1508 end if;
1510 Append_Elmt (Loop_Node, Label_List);
1511 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1512 End_Statements (Loop_Node);
1513 return Loop_Node;
1514 end P_Loop_Statement;
1516 -- P_For_Statement
1518 -- This function parses a loop statement with a FOR iteration scheme
1520 -- The caller has checked that the initial token is FOR. The parameter
1521 -- is the node identifier for the block label if any (or is set to Empty
1522 -- if there is no block label).
1524 -- Note: the caller fills in the Identifier field if a label was present
1526 -- Error recovery: can raise Error_Resync
1528 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1529 Loop_Node : Node_Id;
1530 Iter_Scheme_Node : Node_Id;
1531 Loop_For_Flag : Boolean;
1532 Created_Name : Node_Id;
1533 Spec : Node_Id;
1535 begin
1536 Push_Scope_Stack;
1537 Scope.Table (Scope.Last).Labl := Loop_Name;
1538 Scope.Table (Scope.Last).Ecol := Start_Column;
1539 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1540 Scope.Table (Scope.Last).Etyp := E_Loop;
1542 Loop_For_Flag := (Prev_Token = Tok_Loop);
1543 Scan; -- past FOR
1544 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1545 Spec := P_Loop_Parameter_Specification;
1547 if Nkind (Spec) = N_Loop_Parameter_Specification then
1548 Set_Loop_Parameter_Specification (Iter_Scheme_Node, Spec);
1549 else
1550 Set_Iterator_Specification (Iter_Scheme_Node, Spec);
1551 end if;
1553 -- The following is a special test so that a miswritten for loop such
1554 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1555 -- entry in the scope stack. We don't bother to actually fix up the
1556 -- tree in this case since it's not worth the effort. Instead we just
1557 -- eat up the loop junk, leaving the entry for what now looks like an
1558 -- unmodified loop intact.
1560 if Loop_For_Flag and then Token = Tok_Semicolon then
1561 Error_Msg_SC ("LOOP belongs here, not before FOR");
1562 Pop_Scope_Stack;
1563 return Error;
1565 -- Normal case
1567 else
1568 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1570 if No (Loop_Name) then
1571 Created_Name :=
1572 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
1573 Set_Comes_From_Source (Created_Name, False);
1574 Set_Has_Created_Identifier (Loop_Node, True);
1575 Set_Identifier (Loop_Node, Created_Name);
1576 Scope.Table (Scope.Last).Labl := Created_Name;
1577 else
1578 Set_Identifier (Loop_Node, Loop_Name);
1579 end if;
1581 TF_Loop;
1582 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1583 End_Statements (Loop_Node);
1584 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1585 Append_Elmt (Loop_Node, Label_List);
1586 return Loop_Node;
1587 end if;
1588 end P_For_Statement;
1590 -- P_While_Statement
1592 -- This procedure scans a loop statement with a WHILE iteration scheme
1594 -- The caller has checked that the initial token is WHILE. The parameter
1595 -- is the node identifier for the block label if any (or is set to Empty
1596 -- if there is no block label).
1598 -- Error recovery: cannot raise Error_Resync
1600 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1601 Loop_Node : Node_Id;
1602 Iter_Scheme_Node : Node_Id;
1603 Loop_While_Flag : Boolean;
1604 Created_Name : Node_Id;
1606 begin
1607 Push_Scope_Stack;
1608 Scope.Table (Scope.Last).Labl := Loop_Name;
1609 Scope.Table (Scope.Last).Ecol := Start_Column;
1610 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1611 Scope.Table (Scope.Last).Etyp := E_Loop;
1613 Loop_While_Flag := (Prev_Token = Tok_Loop);
1614 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1615 Scan; -- past WHILE
1616 Set_Condition (Iter_Scheme_Node, P_Condition);
1618 -- The following is a special test so that a miswritten for loop such
1619 -- as "loop while I > 10;" is handled nicely, without making an extra
1620 -- entry in the scope stack. We don't bother to actually fix up the
1621 -- tree in this case since it's not worth the effort. Instead we just
1622 -- eat up the loop junk, leaving the entry for what now looks like an
1623 -- unmodified loop intact.
1625 if Loop_While_Flag and then Token = Tok_Semicolon then
1626 Error_Msg_SC ("LOOP belongs here, not before WHILE");
1627 Pop_Scope_Stack;
1628 return Error;
1630 -- Normal case
1632 else
1633 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1634 TF_Loop;
1636 if No (Loop_Name) then
1637 Created_Name :=
1638 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
1639 Set_Comes_From_Source (Created_Name, False);
1640 Set_Has_Created_Identifier (Loop_Node, True);
1641 Set_Identifier (Loop_Node, Created_Name);
1642 Scope.Table (Scope.Last).Labl := Created_Name;
1643 else
1644 Set_Identifier (Loop_Node, Loop_Name);
1645 end if;
1647 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1648 End_Statements (Loop_Node);
1649 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1650 Append_Elmt (Loop_Node, Label_List);
1651 return Loop_Node;
1652 end if;
1653 end P_While_Statement;
1655 ---------------------------------------
1656 -- 5.5 Loop Parameter Specification --
1657 ---------------------------------------
1659 -- LOOP_PARAMETER_SPECIFICATION ::=
1660 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1662 -- Error recovery: cannot raise Error_Resync
1664 function P_Loop_Parameter_Specification return Node_Id is
1665 Loop_Param_Specification_Node : Node_Id;
1667 ID_Node : Node_Id;
1668 Scan_State : Saved_Scan_State;
1670 begin
1672 Save_Scan_State (Scan_State);
1673 ID_Node := P_Defining_Identifier (C_In);
1675 -- If the next token is OF, it indicates an Ada 2012 iterator. If the
1676 -- next token is a colon, this is also an Ada 2012 iterator, including
1677 -- a subtype indication for the loop parameter. Otherwise we parse the
1678 -- construct as a loop parameter specification. Note that the form
1679 -- "for A in B" is ambiguous, and must be resolved semantically: if B
1680 -- is a discrete subtype this is a loop specification, but if it is an
1681 -- expression it is an iterator specification. Ambiguity is resolved
1682 -- during analysis of the loop parameter specification.
1684 if Token = Tok_Of or else Token = Tok_Colon then
1685 Error_Msg_Ada_2012_Feature ("iterator", Token_Ptr);
1686 return P_Iterator_Specification (ID_Node);
1687 end if;
1689 -- The span of the Loop_Parameter_Specification starts at the
1690 -- defining identifier.
1692 Loop_Param_Specification_Node :=
1693 New_Node (N_Loop_Parameter_Specification, Sloc (ID_Node));
1694 Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
1696 if Token = Tok_Left_Paren then
1697 Error_Msg_SC ("subscripted loop parameter not allowed");
1698 Restore_Scan_State (Scan_State);
1699 Discard_Junk_Node (P_Name);
1701 elsif Token = Tok_Dot then
1702 Error_Msg_SC ("selected loop parameter not allowed");
1703 Restore_Scan_State (Scan_State);
1704 Discard_Junk_Node (P_Name);
1705 end if;
1707 T_In;
1709 if Token = Tok_Reverse then
1710 Scan; -- past REVERSE
1711 Set_Reverse_Present (Loop_Param_Specification_Node, True);
1712 end if;
1714 Set_Discrete_Subtype_Definition
1715 (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
1716 return Loop_Param_Specification_Node;
1718 exception
1719 when Error_Resync =>
1720 return Error;
1721 end P_Loop_Parameter_Specification;
1723 ----------------------------------
1724 -- 5.5.1 Iterator_Specification --
1725 ----------------------------------
1727 function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id is
1728 Node1 : Node_Id;
1730 begin
1731 Node1 := New_Node (N_Iterator_Specification, Sloc (Def_Id));
1732 Set_Defining_Identifier (Node1, Def_Id);
1734 if Token = Tok_Colon then
1735 Scan; -- past :
1736 Set_Subtype_Indication (Node1, P_Subtype_Indication);
1737 end if;
1739 if Token = Tok_Of then
1740 Set_Of_Present (Node1);
1741 Scan; -- past OF
1743 elsif Token = Tok_In then
1744 Scan; -- past IN
1746 elsif Prev_Token = Tok_In
1747 and then Present (Subtype_Indication (Node1))
1748 then
1749 -- Simplest recovery is to transform it into an element iterator.
1750 -- Error message on 'in" has already been emitted when parsing the
1751 -- optional constraint.
1753 Set_Of_Present (Node1);
1754 Error_Msg_N
1755 ("subtype indication is only legal on an element iterator",
1756 Subtype_Indication (Node1));
1758 else
1759 return Error;
1760 end if;
1762 if Token = Tok_Reverse then
1763 Scan; -- past REVERSE
1764 Set_Reverse_Present (Node1, True);
1765 end if;
1767 Set_Name (Node1, P_Name);
1768 return Node1;
1769 end P_Iterator_Specification;
1771 --------------------------
1772 -- 5.6 Block Statement --
1773 --------------------------
1775 -- BLOCK_STATEMENT ::=
1776 -- [block_STATEMENT_IDENTIFIER:]
1777 -- [declare
1778 -- DECLARATIVE_PART]
1779 -- begin
1780 -- HANDLED_SEQUENCE_OF_STATEMENTS
1781 -- end [block_IDENTIFIER];
1783 -- The parsing of block statements is handled by one of the two functions
1784 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1785 -- a declare section is present
1787 -- P_Declare_Statement
1789 -- This function parses a block statement with DECLARE present
1791 -- The caller has checked that the initial token is DECLARE
1793 -- Error recovery: cannot raise Error_Resync
1795 function P_Declare_Statement
1796 (Block_Name : Node_Id := Empty)
1797 return Node_Id
1799 Block_Node : Node_Id;
1800 Created_Name : Node_Id;
1802 begin
1803 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1805 Push_Scope_Stack;
1806 Scope.Table (Scope.Last).Etyp := E_Name;
1807 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1808 Scope.Table (Scope.Last).Ecol := Start_Column;
1809 Scope.Table (Scope.Last).Labl := Block_Name;
1810 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1812 Scan; -- past DECLARE
1814 if No (Block_Name) then
1815 Created_Name :=
1816 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
1817 Set_Comes_From_Source (Created_Name, False);
1818 Set_Has_Created_Identifier (Block_Node, True);
1819 Set_Identifier (Block_Node, Created_Name);
1820 Scope.Table (Scope.Last).Labl := Created_Name;
1821 else
1822 Set_Identifier (Block_Node, Block_Name);
1823 end if;
1825 Append_Elmt (Block_Node, Label_List);
1826 Parse_Decls_Begin_End (Block_Node);
1827 return Block_Node;
1828 end P_Declare_Statement;
1830 -- P_Begin_Statement
1832 -- This function parses a block statement with no DECLARE present
1834 -- The caller has checked that the initial token is BEGIN
1836 -- Error recovery: cannot raise Error_Resync
1838 function P_Begin_Statement
1839 (Block_Name : Node_Id := Empty)
1840 return Node_Id
1842 Block_Node : Node_Id;
1843 Created_Name : Node_Id;
1845 begin
1846 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1848 Push_Scope_Stack;
1849 Scope.Table (Scope.Last).Etyp := E_Name;
1850 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
1851 Scope.Table (Scope.Last).Ecol := Start_Column;
1852 Scope.Table (Scope.Last).Labl := Block_Name;
1853 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1855 if No (Block_Name) then
1856 Created_Name :=
1857 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
1858 Set_Comes_From_Source (Created_Name, False);
1859 Set_Has_Created_Identifier (Block_Node, True);
1860 Set_Identifier (Block_Node, Created_Name);
1861 Scope.Table (Scope.Last).Labl := Created_Name;
1862 else
1863 Set_Identifier (Block_Node, Block_Name);
1864 end if;
1866 Append_Elmt (Block_Node, Label_List);
1868 Scope.Table (Scope.Last).Ecol := Start_Column;
1869 Scope.Table (Scope.Last).Sloc := Token_Ptr;
1870 Scan; -- past BEGIN
1871 Set_Handled_Statement_Sequence
1872 (Block_Node, P_Handled_Sequence_Of_Statements);
1873 End_Statements (Handled_Statement_Sequence (Block_Node));
1874 return Block_Node;
1875 end P_Begin_Statement;
1877 -------------------------
1878 -- 5.7 Exit Statement --
1879 -------------------------
1881 -- EXIT_STATEMENT ::=
1882 -- exit [loop_NAME] [when CONDITION];
1884 -- The caller has checked that the initial token is EXIT
1886 -- Error recovery: can raise Error_Resync
1888 function P_Exit_Statement return Node_Id is
1889 Exit_Node : Node_Id;
1891 function Missing_Semicolon_On_Exit return Boolean;
1892 -- This function deals with the following specialized situation
1894 -- when 'x' =>
1895 -- exit [identifier]
1896 -- when 'y' =>
1898 -- This looks like a messed up EXIT WHEN, when in fact the problem
1899 -- is a missing semicolon. It is called with Token pointing to the
1900 -- WHEN token, and returns True if a semicolon is missing before
1901 -- the WHEN as in the above example.
1903 -------------------------------
1904 -- Missing_Semicolon_On_Exit --
1905 -------------------------------
1907 function Missing_Semicolon_On_Exit return Boolean is
1908 State : Saved_Scan_State;
1910 begin
1911 if not Token_Is_At_Start_Of_Line then
1912 return False;
1914 elsif Scope.Table (Scope.Last).Etyp /= E_Case then
1915 return False;
1917 else
1918 Save_Scan_State (State);
1919 Scan; -- past WHEN
1920 Scan; -- past token after WHEN
1922 if Token = Tok_Arrow then
1923 Restore_Scan_State (State);
1924 return True;
1925 else
1926 Restore_Scan_State (State);
1927 return False;
1928 end if;
1929 end if;
1930 end Missing_Semicolon_On_Exit;
1932 -- Start of processing for P_Exit_Statement
1934 begin
1935 Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
1936 Scan; -- past EXIT
1938 if Token = Tok_Identifier then
1939 Set_Name (Exit_Node, P_Qualified_Simple_Name);
1941 elsif Style_Check then
1942 -- This EXIT has no name, so check that
1943 -- the innermost loop is unnamed too.
1945 Check_No_Exit_Name :
1946 for J in reverse 1 .. Scope.Last loop
1947 if Scope.Table (J).Etyp = E_Loop then
1948 if Present (Scope.Table (J).Labl)
1949 and then Comes_From_Source (Scope.Table (J).Labl)
1950 then
1951 -- Innermost loop in fact had a name, style check fails
1953 Style.No_Exit_Name (Scope.Table (J).Labl);
1954 end if;
1956 exit Check_No_Exit_Name;
1957 end if;
1958 end loop Check_No_Exit_Name;
1959 end if;
1961 if Token = Tok_When and then not Missing_Semicolon_On_Exit then
1962 Scan; -- past WHEN
1963 Set_Condition (Exit_Node, P_Condition);
1965 -- Allow IF instead of WHEN, giving error message
1967 elsif Token = Tok_If then
1968 T_When;
1969 Scan; -- past IF used in place of WHEN
1970 Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
1971 end if;
1973 TF_Semicolon;
1974 return Exit_Node;
1975 end P_Exit_Statement;
1977 -------------------------
1978 -- 5.8 Goto Statement --
1979 -------------------------
1981 -- GOTO_STATEMENT ::= goto label_NAME;
1983 -- The caller has checked that the initial token is GOTO (or TO in the
1984 -- error case where GO and TO were incorrectly separated).
1986 -- Error recovery: can raise Error_Resync
1988 function P_Goto_Statement return Node_Id is
1989 Goto_Node : Node_Id;
1991 begin
1992 Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
1993 Scan; -- past GOTO (or TO)
1994 Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
1995 Append_Elmt (Goto_Node, Goto_List);
1996 No_Constraint;
1997 TF_Semicolon;
1998 return Goto_Node;
1999 end P_Goto_Statement;
2001 ---------------------------
2002 -- Parse_Decls_Begin_End --
2003 ---------------------------
2005 -- This function parses the construct:
2007 -- DECLARATIVE_PART
2008 -- begin
2009 -- HANDLED_SEQUENCE_OF_STATEMENTS
2010 -- end [NAME];
2012 -- The caller has built the scope stack entry, and created the node to
2013 -- whose Declarations and Handled_Statement_Sequence fields are to be
2014 -- set. On return these fields are filled in (except in the case of a
2015 -- task body, where the handled statement sequence is optional, and may
2016 -- thus be Empty), and the scan is positioned past the End sequence.
2018 -- If the BEGIN is missing, then the parent node is used to help construct
2019 -- an appropriate missing BEGIN message. Possibilities for the parent are:
2021 -- N_Block_Statement declare block
2022 -- N_Entry_Body entry body
2023 -- N_Package_Body package body (begin part optional)
2024 -- N_Subprogram_Body procedure or function body
2025 -- N_Task_Body task body
2027 -- Note: in the case of a block statement, there is definitely a DECLARE
2028 -- present (because a Begin statement without a DECLARE is handled by the
2029 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
2031 -- Error recovery: cannot raise Error_Resync
2033 procedure Parse_Decls_Begin_End (Parent : Node_Id) is
2034 Body_Decl : Node_Id;
2035 Decls : List_Id;
2036 Parent_Nkind : Node_Kind;
2037 Spec_Node : Node_Id;
2038 HSS : Node_Id;
2040 procedure Missing_Begin (Msg : String);
2041 -- Called to post a missing begin message. In the normal case this is
2042 -- posted at the start of the current token. A special case arises when
2043 -- P_Declarative_Items has previously found a missing begin, in which
2044 -- case we replace the original error message.
2046 procedure Set_Null_HSS (Parent : Node_Id);
2047 -- Construct an empty handled statement sequence and install in Parent
2048 -- Leaves HSS set to reference the newly constructed statement sequence.
2050 -------------------
2051 -- Missing_Begin --
2052 -------------------
2054 procedure Missing_Begin (Msg : String) is
2055 begin
2056 if Missing_Begin_Msg = No_Error_Msg then
2057 Error_Msg_BC (Msg);
2058 else
2059 Change_Error_Text (Missing_Begin_Msg, Msg);
2061 -- Purge any messages issued after than, since a missing begin
2062 -- can cause a lot of havoc, and it is better not to dump these
2063 -- cascaded messages on the user.
2065 Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
2066 end if;
2067 end Missing_Begin;
2069 ------------------
2070 -- Set_Null_HSS --
2071 ------------------
2073 procedure Set_Null_HSS (Parent : Node_Id) is
2074 Null_Stm : Node_Id;
2076 begin
2077 Null_Stm :=
2078 Make_Null_Statement (Token_Ptr);
2079 Set_Comes_From_Source (Null_Stm, False);
2081 HSS :=
2082 Make_Handled_Sequence_Of_Statements (Token_Ptr,
2083 Statements => New_List (Null_Stm));
2084 Set_Comes_From_Source (HSS, False);
2086 Set_Handled_Statement_Sequence (Parent, HSS);
2087 end Set_Null_HSS;
2089 -- Start of processing for Parse_Decls_Begin_End
2091 begin
2092 Decls := P_Declarative_Part;
2094 if Ada_Version = Ada_83 then
2095 Check_Later_Vs_Basic_Declarations (Decls, During_Parsing => True);
2096 end if;
2098 -- Here is where we deal with the case of IS used instead of semicolon.
2099 -- Specifically, if the last declaration in the declarative part is a
2100 -- subprogram body still marked as having a bad IS, then this is where
2101 -- we decide that the IS should really have been a semicolon and that
2102 -- the body should have been a declaration. Note that if the bad IS
2103 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2104 -- then the Bad_Is_Detected flag would have been reset by now.
2106 Body_Decl := Last (Decls);
2108 if Present (Body_Decl)
2109 and then Nkind (Body_Decl) = N_Subprogram_Body
2110 and then Bad_Is_Detected (Body_Decl)
2111 then
2112 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2113 -- What we have now is a subprogram body with attached declarations
2114 -- and a possible statement sequence.
2116 -- First step is to take the declarations that were part of the bogus
2117 -- subprogram body and append them to the outer declaration chain.
2118 -- In other words we append them past the body (which we will later
2119 -- convert into a declaration).
2121 Append_List (Declarations (Body_Decl), Decls);
2123 -- Now take the handled statement sequence of the bogus body and
2124 -- set it as the statement sequence for the outer construct. Note
2125 -- that it may be empty (we specially allowed a missing BEGIN for
2126 -- a subprogram body marked as having a bad IS -- see below).
2128 Set_Handled_Statement_Sequence (Parent,
2129 Handled_Statement_Sequence (Body_Decl));
2131 -- Next step is to convert the old body node to a declaration node
2133 Spec_Node := Specification (Body_Decl);
2134 Change_Node (Body_Decl, N_Subprogram_Declaration);
2135 Set_Specification (Body_Decl, Spec_Node);
2137 -- Final step is to put the declarations for the parent where
2138 -- they belong, and then fall through the IF to scan out the
2139 -- END statements.
2141 Set_Declarations (Parent, Decls);
2143 -- This is the normal case (i.e. any case except the bad IS case)
2144 -- If we have a BEGIN, then scan out the sequence of statements, and
2145 -- also reset the expected column for the END to match the BEGIN.
2147 else
2148 Set_Declarations (Parent, Decls);
2150 if Token = Tok_Begin then
2151 if Style_Check then
2152 Style.Check_Indentation;
2153 end if;
2155 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
2157 if RM_Column_Check
2158 and then Token_Is_At_Start_Of_Line
2159 and then Start_Column /= Error_Msg_Col
2160 then
2161 Error_Msg_SC ("(style) BEGIN in wrong column, should be@");
2163 else
2164 Scope.Table (Scope.Last).Ecol := Start_Column;
2165 end if;
2167 Scope.Table (Scope.Last).Sloc := Token_Ptr;
2168 Scan; -- past BEGIN
2169 Set_Handled_Statement_Sequence (Parent,
2170 P_Handled_Sequence_Of_Statements);
2172 -- No BEGIN present
2174 else
2175 Parent_Nkind := Nkind (Parent);
2177 -- A special check for the missing IS case. If we have a
2178 -- subprogram body that was marked as having a suspicious
2179 -- IS, and the current token is END, then we simply confirm
2180 -- the suspicion, and do not require a BEGIN to be present
2182 if Parent_Nkind = N_Subprogram_Body
2183 and then Token = Tok_End
2184 and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is
2185 then
2186 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
2188 -- Otherwise BEGIN is not required for a package body, so we
2189 -- don't mind if it is missing, but we do construct a dummy
2190 -- one (so that we have somewhere to set End_Label).
2192 -- However if we have something other than a BEGIN which
2193 -- looks like it might be statements, then we signal a missing
2194 -- BEGIN for these cases as well. We define "something which
2195 -- looks like it might be statements" as a token other than
2196 -- END, EOF, or a token which starts declarations.
2198 elsif Parent_Nkind = N_Package_Body
2199 and then (Token = Tok_End
2200 or else Token = Tok_EOF
2201 or else Token in Token_Class_Declk)
2202 then
2203 Set_Null_HSS (Parent);
2205 -- These are cases in which a BEGIN is required and not present
2207 else
2208 Set_Null_HSS (Parent);
2210 -- Prepare to issue error message
2212 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
2213 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
2215 -- Now issue appropriate message
2217 if Parent_Nkind = N_Block_Statement then
2218 Missing_Begin ("missing BEGIN for DECLARE#!");
2220 elsif Parent_Nkind = N_Entry_Body then
2221 Missing_Begin ("missing BEGIN for ENTRY#!");
2223 elsif Parent_Nkind = N_Subprogram_Body then
2224 if Nkind (Specification (Parent))
2225 = N_Function_Specification
2226 then
2227 Missing_Begin ("missing BEGIN for function&#!");
2228 else
2229 Missing_Begin ("missing BEGIN for procedure&#!");
2230 end if;
2232 -- The case for package body arises only when
2233 -- we have possible statement junk present.
2235 elsif Parent_Nkind = N_Package_Body then
2236 Missing_Begin ("missing BEGIN for package body&#!");
2238 else
2239 pragma Assert (Parent_Nkind = N_Task_Body);
2240 Missing_Begin ("missing BEGIN for task body&#!");
2241 end if;
2243 -- Here we pick up the statements after the BEGIN that
2244 -- should have been present but was not. We don't insist
2245 -- on statements being present if P_Declarative_Part had
2246 -- already found a missing BEGIN, since it might have
2247 -- swallowed a lone statement into the declarative part.
2249 if Missing_Begin_Msg /= No_Error_Msg
2250 and then Token = Tok_End
2251 then
2252 null;
2253 else
2254 Set_Handled_Statement_Sequence (Parent,
2255 P_Handled_Sequence_Of_Statements);
2256 end if;
2257 end if;
2258 end if;
2259 end if;
2261 -- Here with declarations and handled statement sequence scanned
2263 if Present (Handled_Statement_Sequence (Parent)) then
2264 End_Statements (Handled_Statement_Sequence (Parent));
2265 else
2266 End_Statements;
2267 end if;
2269 -- We know that End_Statements removed an entry from the scope stack
2270 -- (because it is required to do so under all circumstances). We can
2271 -- therefore reference the entry it removed one past the stack top.
2272 -- What we are interested in is whether it was a case of a bad IS.
2274 if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
2275 Error_Msg -- CODEFIX
2276 ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
2277 Set_Bad_Is_Detected (Parent, True);
2278 end if;
2280 end Parse_Decls_Begin_End;
2282 -------------------------
2283 -- Set_Loop_Block_Name --
2284 -------------------------
2286 function Set_Loop_Block_Name (L : Character) return Name_Id is
2287 begin
2288 Name_Buffer (1) := L;
2289 Name_Buffer (2) := '_';
2290 Name_Len := 2;
2291 Loop_Block_Count := Loop_Block_Count + 1;
2292 Add_Nat_To_Name_Buffer (Loop_Block_Count);
2293 return Name_Find;
2294 end Set_Loop_Block_Name;
2296 ---------------
2297 -- Then_Scan --
2298 ---------------
2300 procedure Then_Scan is
2301 begin
2302 TF_Then;
2304 while Token = Tok_Then loop
2305 Error_Msg_SC -- CODEFIX
2306 ("redundant THEN");
2307 TF_Then;
2308 end loop;
2310 if Token = Tok_And or else Token = Tok_Or then
2311 Error_Msg_SC ("unexpected logical operator");
2312 Scan; -- past logical operator
2314 if (Prev_Token = Tok_And and then Token = Tok_Then)
2315 or else
2316 (Prev_Token = Tok_Or and then Token = Tok_Else)
2317 then
2318 Scan;
2319 end if;
2321 Discard_Junk_Node (P_Expression);
2322 end if;
2324 if Token = Tok_Then then
2325 Scan;
2326 end if;
2327 end Then_Scan;
2329 end Ch5;