Add assember CFI directives to millicode division and remainder routines.
[official-gcc.git] / gcc / ada / par-ch5.adb
blob418547b1ceab3314eb22f645e0bfb19ab299bdbc
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-2023, 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_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
66 -- Parse loop statement. If Loop_Name is non-Empty on entry, it is
67 -- the N_Identifier node for the label on the loop. If Loop_Name is
68 -- Empty on entry (the default), then the loop statement is unlabeled.
70 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
71 -- Parse while statement. If Loop_Name is non-Empty on entry, it is
72 -- the N_Identifier node for the label on the loop. If Loop_Name is
73 -- Empty on entry (the default), then the while statement is unlabeled.
75 function Set_Loop_Block_Name (L : Character) return Name_Id;
76 -- Given a letter 'L' for a loop or 'B' for a block, returns a name
77 -- of the form L_nn or B_nn where nn is a serial number obtained by
78 -- incrementing the variable Loop_Block_Count.
80 procedure Then_Scan;
81 -- Scan past THEN token, testing for illegal junk after it
83 ---------------------------------
84 -- 5.1 Sequence of Statements --
85 ---------------------------------
87 -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} {LABEL}
88 -- Note: the final label is an Ada 2012 addition.
90 -- STATEMENT ::=
91 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
93 -- SIMPLE_STATEMENT ::= NULL_STATEMENT
94 -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT
95 -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT
96 -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT
97 -- | REQUEUE_STATEMENT | DELAY_STATEMENT
98 -- | ABORT_STATEMENT | RAISE_STATEMENT
99 -- | CODE_STATEMENT
101 -- COMPOUND_STATEMENT ::=
102 -- IF_STATEMENT | CASE_STATEMENT
103 -- | LOOP_STATEMENT | BLOCK_STATEMENT
104 -- | ACCEPT_STATEMENT | SELECT_STATEMENT
106 -- This procedure scans a sequence of statements. SS_Flags indicates
107 -- termination conditions for the sequence. In addition, the sequence is
108 -- always terminated by encountering END or end of file. If one of the six
109 -- above terminators is encountered with the corresponding SS_Flags flag
110 -- not set, then the action taken is as follows:
112 -- If the keyword occurs to the left of the expected column of the end
113 -- for the current sequence (as recorded in the current end context),
114 -- then it is assumed to belong to an outer context, and is considered
115 -- to terminate the sequence of statements.
117 -- If the keyword occurs to the right of, or in the expected column of
118 -- the end for the current sequence, then an error message is output,
119 -- the keyword together with its associated context is skipped, and
120 -- the statement scan continues until another terminator is found.
122 -- Note that the first action means that control can return to the caller
123 -- with Token set to a terminator other than one of those specified by the
124 -- SS_Flags parameter. The caller should treat such a case as equivalent to
125 -- END.
127 -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at
128 -- least one real statement (other than a pragma) is required in the
129 -- statement sequence. During the processing of the sequence, this
130 -- flag is manipulated to indicate the current status of the requirement
131 -- for a statement. For example, it is turned off by the occurrence of a
132 -- statement, and back on by a label (which requires a following statement)
134 -- Error recovery: cannot raise Error_Resync. If an error occurs during
135 -- parsing a statement, then the scan pointer is advanced past the next
136 -- semicolon and the parse continues.
138 function P_Sequence_Of_Statements
139 (SS_Flags : SS_Rec; Handled : Boolean := False) return List_Id
141 Statement_Required : Boolean := SS_Flags.Sreq;
142 -- This flag indicates if a subsequent statement (other than a pragma)
143 -- is required. It is initialized from the Sreq flag, and modified as
144 -- statements are scanned (a statement turns it off, and a label turns
145 -- it back on again since a statement must follow a label).
146 -- Note : this final requirement is lifted in Ada 2012.
148 Statement_Seen : Boolean := False;
149 -- In Ada 2012, a label can end a sequence of statements, but the
150 -- sequence cannot contain only labels. This flag is set whenever a
151 -- label is encountered, to enforce this rule at the end of a sequence.
153 Scan_State_Label : Saved_Scan_State;
154 Scan_State : Saved_Scan_State;
156 Statement_List : constant List_Id := New_List;
157 Block_Label : Name_Id;
158 Id_Node : Node_Id;
159 Name_Node : Node_Id;
161 Decl_Loc, Label_Loc : Source_Ptr := No_Location;
162 -- Sloc of the first declaration/label encountered, if any.
164 procedure Test_Statement_Required;
165 -- Flag error if Statement_Required flag set
167 -----------------------------
168 -- Test_Statement_Required --
169 -----------------------------
171 procedure Test_Statement_Required is
172 function All_Pragmas return Boolean;
173 -- Return True if statement list is all pragmas
175 -----------------
176 -- All_Pragmas --
177 -----------------
179 function All_Pragmas return Boolean is
180 S : Node_Id;
181 begin
182 S := First (Statement_List);
183 while Present (S) loop
184 if Nkind (S) /= N_Pragma then
185 return False;
186 else
187 Next (S);
188 end if;
189 end loop;
191 return True;
192 end All_Pragmas;
194 -- Start of processing for Test_Statement_Required
196 begin
197 if Statement_Required then
199 -- Check no statement required after label in Ada 2012, and that
200 -- it is OK to have nothing but pragmas in a statement sequence.
202 if Ada_Version >= Ada_2012
203 and then not Is_Empty_List (Statement_List)
204 and then
205 ((Nkind (Last (Statement_List)) = N_Label
206 and then Statement_Seen)
207 or else All_Pragmas)
208 then
209 null;
211 -- If not Ada 2012, or not special case above, and no declaration
212 -- seen (as allowed in Ada 2020), give error message.
214 elsif No (Decl_Loc) then
215 Error_Msg_BC -- CODEFIX
216 ("statement expected");
217 end if;
218 end if;
219 end Test_Statement_Required;
221 -- Start of processing for P_Sequence_Of_Statements
223 begin
224 -- In Ada 2022, we allow declarative items to be mixed with
225 -- statements. The loop below alternates between calling
226 -- P_Declarative_Items to parse zero or more declarative items,
227 -- and parsing a statement.
229 loop
230 Ignore (Tok_Semicolon);
232 declare
233 Num_Statements : constant Nat := List_Length (Statement_List);
234 begin
235 P_Declarative_Items
236 (Statement_List, Declare_Expression => False,
237 In_Spec => False, In_Statements => True);
239 -- Use the length of the list to determine whether we parsed
240 -- any declarative items. If so, it's an error unless language
241 -- extensions are enabled.
243 if List_Length (Statement_List) > Num_Statements then
244 if All_Errors_Mode or else No (Decl_Loc) then
245 Decl_Loc := Sloc (Pick (Statement_List, Num_Statements + 1));
247 Error_Msg_GNAT_Extension
248 ("declarations mixed with statements",
249 Sloc (Pick (Statement_List, Num_Statements + 1)));
250 end if;
251 end if;
252 end;
254 begin -- handle Error_Resync
255 if Style_Check then
256 Style.Check_Indentation;
257 end if;
259 -- Deal with reserved identifier (in assignment or call)
261 if Is_Reserved_Identifier then
262 Save_Scan_State (Scan_State); -- at possible bad identifier
263 Scan; -- and scan past it
265 -- We have an reserved word which is spelled in identifier
266 -- style, so the question is whether it really is intended
267 -- to be an identifier.
270 -- If followed by a semicolon, then it is an identifier,
271 -- with the exception of the cases tested for below.
273 (Token = Tok_Semicolon
274 and then Prev_Token not in
275 Tok_Return | Tok_Null | Tok_Raise | Tok_End | Tok_Exit)
277 -- If followed by colon, colon-equal, or dot, then we
278 -- definitely have an identifier (could not be reserved)
280 or else Token in Tok_Colon | Tok_Colon_Equal | Tok_Dot
282 -- Left paren means we have an identifier except for those
283 -- reserved words that can legitimately be followed by a
284 -- left paren.
286 or else
287 (Token = Tok_Left_Paren
288 and then Prev_Token not in
289 Tok_Case | Tok_Delay | Tok_If | Tok_Elsif | Tok_Return |
290 Tok_When | Tok_While | Tok_Separate)
291 then
292 -- Here we have an apparent reserved identifier and the
293 -- token past it is appropriate to this usage (and would
294 -- be a definite error if this is not an identifier). What
295 -- we do is to use P_Identifier to fix up the identifier,
296 -- and then fall into the normal processing.
298 Restore_Scan_State (Scan_State); -- back to the ID
299 Scan_Reserved_Identifier (Force_Msg => False);
301 -- Not a reserved identifier after all (or at least we can't
302 -- be sure that it is), so reset the scan and continue.
304 else
305 Restore_Scan_State (Scan_State); -- back to the reserved word
306 end if;
307 end if;
309 -- Now look to see what kind of statement we have
311 case Token is
313 -- Case of end or EOF
315 when Tok_End
316 | Tok_EOF
318 -- These tokens always terminate the statement sequence
320 Test_Statement_Required;
321 exit;
323 -- Case of ELSIF
325 when Tok_Elsif =>
327 -- Terminate if Eftm set or if the ELSIF is to the left
328 -- of the expected column of the end for this sequence
330 if SS_Flags.Eftm
331 or else Start_Column < Scopes (Scope.Last).Ecol
332 then
333 Test_Statement_Required;
334 exit;
336 -- Otherwise complain and skip past ELSIF Condition then
338 else
339 Error_Msg_SC ("ELSIF not allowed here");
340 Scan; -- past ELSIF
341 Discard_Junk_Node (P_Expression_No_Right_Paren);
342 Then_Scan;
343 Statement_Required := False;
344 end if;
346 -- Case of ELSE
348 when Tok_Else =>
350 -- Terminate if Eltm set or if the else is to the left
351 -- of the expected column of the end for this sequence
353 if SS_Flags.Eltm
354 or else Start_Column < Scopes (Scope.Last).Ecol
355 then
356 Test_Statement_Required;
357 exit;
359 -- Otherwise complain and skip past else
361 else
362 Error_Msg_SC ("ELSE not allowed here");
363 Scan; -- past ELSE
364 Statement_Required := False;
365 end if;
367 -- Case of exception
369 when Tok_Exception =>
370 Test_Statement_Required;
372 -- If Extm not set and the exception is not to the left of
373 -- the expected column of the end for this sequence, then we
374 -- assume it belongs to the current sequence, even though it
375 -- is not permitted.
377 if not SS_Flags.Extm and then
378 Start_Column >= Scopes (Scope.Last).Ecol
380 then
381 Error_Msg_SC ("exception handler not permitted here");
382 Scan; -- past EXCEPTION
383 Discard_Junk_List (Parse_Exception_Handlers);
384 end if;
386 -- Always return, in the case where we scanned out handlers
387 -- that we did not expect, Parse_Exception_Handlers returned
388 -- with Token being either end or EOF, so we are OK.
390 exit;
392 -- Case of OR
394 when Tok_Or =>
396 -- Terminate if Ortm set or if the or is to the left of the
397 -- expected column of the end for this sequence.
399 if SS_Flags.Ortm
400 or else Start_Column < Scopes (Scope.Last).Ecol
401 then
402 Test_Statement_Required;
403 exit;
405 -- Otherwise complain and skip past or
407 else
408 Error_Msg_SC ("OR not allowed here");
409 Scan; -- past or
410 Statement_Required := False;
411 end if;
413 -- Case of THEN (deal also with THEN ABORT)
415 when Tok_Then =>
416 Save_Scan_State (Scan_State); -- at THEN
417 Scan; -- past THEN
419 -- Terminate if THEN ABORT allowed (ATC case)
421 exit when SS_Flags.Tatm and then Token = Tok_Abort;
423 -- Otherwise we treat THEN as some kind of mess where we did
424 -- not see the associated IF, but we pick up assuming it had
425 -- been there.
427 Restore_Scan_State (Scan_State); -- to THEN
428 Append_To (Statement_List, P_If_Statement);
429 Statement_Required := False;
431 -- Case of WHEN (error because we are not in a case)
433 when Tok_Others
434 | Tok_When
436 -- Terminate if Whtm set or if the WHEN is to the left of
437 -- the expected column of the end for this sequence.
439 if SS_Flags.Whtm
440 or else Start_Column < Scopes (Scope.Last).Ecol
441 then
442 Test_Statement_Required;
443 exit;
445 -- Otherwise complain and skip when Choice {| Choice} =>
447 else
448 Error_Msg_SC ("WHEN not allowed here");
449 Scan; -- past when
450 Discard_Junk_List (P_Discrete_Choice_List);
451 TF_Arrow;
452 Statement_Required := False;
453 end if;
455 -- Cases of statements starting with an identifier
457 when Tok_Identifier =>
458 Check_Bad_Layout;
460 -- Save scan pointers and line number in case block label
462 Id_Node := Token_Node;
463 Block_Label := Token_Name;
464 Save_Scan_State (Scan_State_Label); -- at possible label
465 Scan; -- past Id
467 -- Check for common case of assignment, since it occurs
468 -- frequently, and we want to process it efficiently.
470 if Token = Tok_Colon_Equal then
471 Scan; -- past the colon-equal
472 Append_To (Statement_List,
473 P_Assignment_Statement (Id_Node));
474 Statement_Required := False;
476 -- Check common case of procedure call, another case that
477 -- we want to speed up as much as possible.
479 elsif Token = Tok_Semicolon then
480 Change_Name_To_Procedure_Call_Statement (Id_Node);
481 Append_To (Statement_List, Id_Node);
482 Scan; -- past semicolon
483 Statement_Required := False;
485 -- Here is the special test for a suspicious label, more
486 -- accurately a suspicious name, which we think perhaps
487 -- should have been a label. If next token is one of
488 -- LOOP, FOR, WHILE, DECLARE, BEGIN, then make an entry
489 -- in the suspicious label table.
491 if Token = Tok_Loop or else
492 Token = Tok_For or else
493 Token = Tok_While or else
494 Token = Tok_Declare or else
495 Token = Tok_Begin
496 then
497 Suspicious_Labels.Append
498 ((Proc_Call => Id_Node,
499 Semicolon_Loc => Prev_Token_Ptr,
500 Start_Token => Token_Ptr));
501 end if;
503 -- Check for case of "go to" in place of "goto"
505 elsif Token = Tok_Identifier
506 and then Block_Label = Name_Go
507 and then Token_Name = Name_To
508 then
509 Error_Msg_SP -- CODEFIX
510 ("goto is one word");
511 Append_To (Statement_List, P_Goto_Statement);
512 Statement_Required := False;
514 -- Check common case of = used instead of :=, just so we
515 -- give a better error message for this special misuse.
517 elsif Token = Tok_Equal then
518 T_Colon_Equal; -- give := expected message
519 Append_To (Statement_List,
520 P_Assignment_Statement (Id_Node));
521 Statement_Required := False;
523 -- Check case of loop label or block label
525 elsif Token = Tok_Colon
526 or else (Token in Token_Class_Labeled_Stmt
527 and then not Token_Is_At_Start_Of_Line)
528 then
529 T_Colon; -- past colon (if there, or msg for missing one)
531 -- Test for more than one label
533 loop
534 exit when Token /= Tok_Identifier;
535 Save_Scan_State (Scan_State); -- at second Id
536 Scan; -- past Id
538 if Token = Tok_Colon then
539 Error_Msg_SP
540 ("only one label allowed on block or loop");
541 Scan; -- past colon on extra label
543 -- Use the second label as the "real" label
545 Scan_State_Label := Scan_State;
547 -- We will set Error_name as the Block_Label since
548 -- we really don't know which of the labels might
549 -- be used at the end of the loop or block.
551 Block_Label := Error_Name;
553 -- If Id with no colon, then backup to point to the
554 -- Id and we will issue the message below when we try
555 -- to scan out the statement as some other form.
557 else
558 Restore_Scan_State (Scan_State); -- to second Id
559 exit;
560 end if;
561 end loop;
563 -- Loop_Statement (labeled Loop_Statement)
565 if Token = Tok_Loop then
566 Append_To (Statement_List,
567 P_Loop_Statement (Id_Node));
569 -- While statement (labeled loop statement with WHILE)
571 elsif Token = Tok_While then
572 Append_To (Statement_List,
573 P_While_Statement (Id_Node));
575 -- Declare statement (labeled block statement with
576 -- DECLARE part)
578 elsif Token = Tok_Declare then
579 Append_To (Statement_List,
580 P_Declare_Statement (Id_Node));
582 -- Begin statement (labeled block statement with no
583 -- DECLARE part)
585 elsif Token = Tok_Begin then
586 Append_To (Statement_List,
587 P_Begin_Statement (Id_Node));
589 -- For statement (labeled loop statement with FOR)
591 elsif Token = Tok_For then
592 Append_To (Statement_List,
593 P_For_Statement (Id_Node));
595 -- Otherwise complain we have inappropriate statement
597 else
598 Error_Msg_AP
599 ("loop or block statement must follow label");
600 end if;
602 Statement_Required := False;
604 -- Here we have an identifier followed by something
605 -- other than a colon, semicolon or assignment symbol.
606 -- The only valid possibility is a name extension symbol
608 elsif Token in Token_Class_Namext then
609 Restore_Scan_State (Scan_State_Label); -- to Id
610 Name_Node := P_Name;
612 -- Skip junk right parens in this context
614 Ignore (Tok_Right_Paren);
616 -- Check context following call
618 if Token = Tok_Colon_Equal then
619 Scan; -- past colon equal
620 Append_To (Statement_List,
621 P_Assignment_Statement (Name_Node));
622 Statement_Required := False;
624 -- Check common case of = used instead of :=
626 elsif Token = Tok_Equal then
627 T_Colon_Equal; -- give := expected message
628 Append_To (Statement_List,
629 P_Assignment_Statement (Name_Node));
630 Statement_Required := False;
632 -- Check apostrophe cases
634 elsif Token = Tok_Apostrophe then
635 Append_To (Statement_List,
636 P_Code_Statement (Name_Node));
637 Statement_Required := False;
639 -- The only other valid item after a name is ; which
640 -- means that the item we just scanned was a call.
642 elsif Token = Tok_Semicolon then
643 Change_Name_To_Procedure_Call_Statement (Name_Node);
644 Append_To (Statement_List, Name_Node);
645 Scan; -- past semicolon
646 Statement_Required := False;
648 -- A slash following an identifier or a selected
649 -- component in this situation is most likely a period
650 -- (see location of keys on keyboard).
652 elsif Token = Tok_Slash
653 and then (Nkind (Name_Node) = N_Identifier
654 or else
655 Nkind (Name_Node) = N_Selected_Component)
656 then
657 Error_Msg_SC -- CODEFIX
658 ("""/"" should be "".""");
659 Statement_Required := False;
660 raise Error_Resync;
662 -- Else we have a missing semicolon
664 else
665 TF_Semicolon;
667 -- Normal processing as though semicolon were present
669 Change_Name_To_Procedure_Call_Statement (Name_Node);
670 Append_To (Statement_List, Name_Node);
671 Statement_Required := False;
672 end if;
674 -- If junk after identifier, check if identifier is an
675 -- instance of an incorrectly spelled keyword. If so, we
676 -- do nothing. The Bad_Spelling_Of will have reset Token
677 -- to the appropriate keyword, so the next time round the
678 -- loop we will process the modified token.
680 -- Note that we check for ELSIF before ELSE here, because
681 -- we don't want to identify a misspelling of ELSE as ELSIF,
682 -- and in particular we do not want to treat ELSEIF as
683 -- ELSE IF.
685 else
686 Restore_Scan_State (Scan_State_Label); -- to identifier
688 if Bad_Spelling_Of (Tok_Abort)
689 or else Bad_Spelling_Of (Tok_Accept)
690 or else Bad_Spelling_Of (Tok_Case)
691 or else Bad_Spelling_Of (Tok_Declare)
692 or else Bad_Spelling_Of (Tok_Delay)
693 or else Bad_Spelling_Of (Tok_Elsif)
694 or else Bad_Spelling_Of (Tok_Else)
695 or else Bad_Spelling_Of (Tok_End)
696 or else Bad_Spelling_Of (Tok_Exception)
697 or else Bad_Spelling_Of (Tok_Exit)
698 or else Bad_Spelling_Of (Tok_For)
699 or else Bad_Spelling_Of (Tok_Goto)
700 or else Bad_Spelling_Of (Tok_If)
701 or else Bad_Spelling_Of (Tok_Loop)
702 or else Bad_Spelling_Of (Tok_Or)
703 or else Bad_Spelling_Of (Tok_Pragma)
704 or else Bad_Spelling_Of (Tok_Raise)
705 or else Bad_Spelling_Of (Tok_Requeue)
706 or else Bad_Spelling_Of (Tok_Return)
707 or else Bad_Spelling_Of (Tok_Select)
708 or else Bad_Spelling_Of (Tok_When)
709 or else Bad_Spelling_Of (Tok_While)
710 then
711 null;
713 -- If not a bad spelling, then we really have junk
715 else
716 Scan; -- past identifier again
718 -- If next token is first token on line, then we
719 -- consider that we were missing a semicolon after
720 -- the identifier, and process it as a procedure
721 -- call with no parameters.
723 if Token_Is_At_Start_Of_Line then
724 Change_Name_To_Procedure_Call_Statement (Id_Node);
725 Append_To (Statement_List, Id_Node);
726 T_Semicolon; -- to give error message
727 Statement_Required := False;
729 -- Otherwise we give a missing := message and
730 -- simply abandon the junk that is there now.
732 else
733 T_Colon_Equal; -- give := expected message
734 raise Error_Resync;
735 end if;
737 end if;
738 end if;
740 -- Statement starting with operator symbol. This could be
741 -- a call, a name starting an assignment, or a qualified
742 -- expression.
744 when Tok_Operator_Symbol =>
745 Check_Bad_Layout;
746 Name_Node := P_Name;
748 -- An attempt at a range attribute or a qualified expression
749 -- must be illegal here (a code statement cannot possibly
750 -- allow qualification by a function name).
752 if Token = Tok_Apostrophe then
753 Error_Msg_SC ("apostrophe illegal here");
754 raise Error_Resync;
755 end if;
757 -- Scan possible assignment if we have a name
759 if Expr_Form = EF_Name
760 and then Token = Tok_Colon_Equal
761 then
762 Scan; -- past colon equal
763 Append_To (Statement_List,
764 P_Assignment_Statement (Name_Node));
765 else
766 Change_Name_To_Procedure_Call_Statement (Name_Node);
767 Append_To (Statement_List, Name_Node);
768 end if;
770 TF_Semicolon;
771 Statement_Required := False;
773 -- Label starting with << which must precede real statement
774 -- Note: in Ada 2012, the label may end the sequence.
776 when Tok_Less_Less =>
777 if Present (Last (Statement_List))
778 and then Nkind (Last (Statement_List)) /= N_Label
779 then
780 Statement_Seen := True;
781 end if;
783 Append_To (Statement_List, P_Label);
784 Statement_Required := True;
786 if No (Label_Loc) then
787 Label_Loc := Sloc (Last (Statement_List));
788 end if;
790 -- Pragma appearing as a statement in a statement sequence
792 when Tok_Pragma =>
793 Check_Bad_Layout;
794 Append_To (Statement_List, P_Pragma);
796 -- Abort_Statement
798 when Tok_Abort =>
799 Check_Bad_Layout;
800 Append_To (Statement_List, P_Abort_Statement);
801 Statement_Required := False;
803 -- Accept_Statement
805 when Tok_Accept =>
806 Check_Bad_Layout;
807 Append_To (Statement_List, P_Accept_Statement);
808 Statement_Required := False;
810 -- Begin_Statement (Block_Statement with no declare, no label)
812 when Tok_Begin =>
813 Check_Bad_Layout;
814 Append_To (Statement_List, P_Begin_Statement);
815 Statement_Required := False;
817 -- Case_Statement
819 when Tok_Case =>
820 Check_Bad_Layout;
821 Append_To (Statement_List, P_Case_Statement);
822 Statement_Required := False;
824 -- Block_Statement with DECLARE and no label
826 when Tok_Declare =>
827 Check_Bad_Layout;
828 Append_To (Statement_List, P_Declare_Statement);
829 Statement_Required := False;
831 -- Delay_Statement
833 when Tok_Delay =>
834 Check_Bad_Layout;
835 Append_To (Statement_List, P_Delay_Statement);
836 Statement_Required := False;
838 -- Exit_Statement
840 when Tok_Exit =>
841 Check_Bad_Layout;
842 Append_To (Statement_List, P_Exit_Statement);
843 Statement_Required := False;
845 -- Loop_Statement with FOR and no label
847 when Tok_For =>
848 Check_Bad_Layout;
849 Append_To (Statement_List, P_For_Statement);
850 Statement_Required := False;
852 -- Goto_Statement
854 when Tok_Goto =>
855 Check_Bad_Layout;
856 Append_To (Statement_List, P_Goto_Statement);
857 Statement_Required := False;
859 -- If_Statement
861 when Tok_If =>
862 Check_Bad_Layout;
863 Append_To (Statement_List, P_If_Statement);
864 Statement_Required := False;
866 -- Loop_Statement
868 when Tok_Loop =>
869 Check_Bad_Layout;
870 Append_To (Statement_List, P_Loop_Statement);
871 Statement_Required := False;
873 -- Null_Statement
875 when Tok_Null =>
876 Check_Bad_Layout;
877 Append_To (Statement_List, P_Null_Statement);
878 Statement_Required := False;
880 -- Raise_Statement
882 when Tok_Raise =>
883 Check_Bad_Layout;
884 Append_To (Statement_List, P_Raise_Statement);
885 Statement_Required := False;
887 -- Requeue_Statement
889 when Tok_Requeue =>
890 Check_Bad_Layout;
891 Append_To (Statement_List, P_Requeue_Statement);
892 Statement_Required := False;
894 -- Return_Statement
896 when Tok_Return =>
897 Check_Bad_Layout;
898 Append_To (Statement_List, P_Return_Statement);
899 Statement_Required := False;
901 -- Select_Statement
903 when Tok_Select =>
904 Check_Bad_Layout;
905 Append_To (Statement_List, P_Select_Statement);
906 Statement_Required := False;
908 -- While_Statement (Block_Statement with while and no loop)
910 when Tok_While =>
911 Check_Bad_Layout;
912 Append_To (Statement_List, P_While_Statement);
913 Statement_Required := False;
915 -- Anything else is some kind of junk, signal an error message
916 -- and then raise Error_Resync, to merge with the normal
917 -- handling of a bad statement.
919 when others =>
920 Error_Msg_BC -- CODEFIX
921 ("statement expected");
922 raise Error_Resync;
923 end case;
925 -- On error resynchronization, skip past next semicolon, and, since
926 -- we are still in the statement loop, look for next statement. We
927 -- set Statement_Required False to avoid an unnecessary error message
928 -- complaining that no statement was found (i.e. we consider the
929 -- junk to satisfy the requirement for a statement being present).
931 exception
932 when Error_Resync =>
933 Resync_Past_Semicolon_Or_To_Loop_Or_Then;
934 Statement_Required := False;
935 end;
937 exit when SS_Flags.Unco;
938 end loop;
940 -- If there are no declarative items in the list, or if the list is part
941 -- of a handled sequence of statements, we just return the list.
942 -- Otherwise, we wrap the list in a block statement, so the declarations
943 -- will have a proper scope. In the Handled case, it would be wrong to
944 -- wrap, because we want the code before and after "begin" to be in the
945 -- same scope. Example:
947 -- if ... then
948 -- use Some_Package;
949 -- Do_Something (...);
950 -- end if;
952 -- is tranformed into:
954 -- if ... then
955 -- begin
956 -- use Some_Package;
957 -- Do_Something (...);
958 -- end;
959 -- end if;
961 -- But we don't wrap this:
963 -- declare
964 -- X : Integer;
965 -- begin
966 -- X : Integer;
968 -- Otherwise, we would fail to detect the error (conflicting X's).
969 -- Similarly, if a representation clause appears in the statement
970 -- part, we don't want it to appear more nested than the declarative
971 -- part -- that would cause an unwanted error.
973 if Present (Decl_Loc) then
974 -- Forbid labels and declarative items from coexisting. Otherwise,
975 -- one could jump past a declaration, leading to chaos. Jumping
976 -- backward past a declaration is also questionable -- does the
977 -- declaration get elaborated again? Is secondary stack storage
978 -- reclaimed? (A more liberal rule was proposed, but this is what
979 -- we're doing for now.)
981 if Present (Label_Loc) then
982 Error_Msg ("declarative item in same list as label", Decl_Loc);
983 Error_Msg ("label in same list as declarative item", Label_Loc);
984 end if;
986 -- Forbid exception handlers and declarative items from
987 -- coexisting. Example:
989 -- X : Integer := 123;
990 -- procedure P is
991 -- begin
992 -- X : Integer := 456;
993 -- exception
994 -- when Cain =>
995 -- Put(X);
996 -- end P;
998 -- It was proposed that in the handler, X should refer to the outer
999 -- X, but that's just confusing.
1001 if Token = Tok_Exception then
1002 Error_Msg
1003 ("declarative item in statements conflicts with " &
1004 "exception handler below",
1005 Decl_Loc);
1006 Error_Msg
1007 ("exception handler conflicts with " &
1008 "declarative item in statements above",
1009 Token_Ptr);
1010 end if;
1012 if Handled then
1013 return Statement_List;
1014 else
1015 declare
1016 Loc : constant Source_Ptr := Sloc (First (Statement_List));
1017 Block : constant Node_Id :=
1018 Make_Block_Statement
1019 (Loc,
1020 Handled_Statement_Sequence =>
1021 Make_Handled_Sequence_Of_Statements
1022 (Loc, Statements => Statement_List));
1023 begin
1024 return New_List (Block);
1025 end;
1026 end if;
1027 else
1028 return Statement_List;
1029 end if;
1030 end P_Sequence_Of_Statements;
1032 --------------------
1033 -- 5.1 Statement --
1034 --------------------
1036 ---------------------------
1037 -- 5.1 Simple Statement --
1038 ---------------------------
1040 -- Parsed by P_Sequence_Of_Statements (5.1)
1042 -----------------------------
1043 -- 5.1 Compound Statement --
1044 -----------------------------
1046 -- Parsed by P_Sequence_Of_Statements (5.1)
1048 -------------------------
1049 -- 5.1 Null Statement --
1050 -------------------------
1052 -- NULL_STATEMENT ::= null;
1054 -- The caller has already checked that the current token is null
1056 -- Error recovery: cannot raise Error_Resync
1058 function P_Null_Statement return Node_Id is
1059 Null_Stmt_Node : Node_Id;
1061 begin
1062 Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr);
1063 Scan; -- past NULL
1064 TF_Semicolon;
1065 return Null_Stmt_Node;
1066 end P_Null_Statement;
1068 ----------------
1069 -- 5.1 Label --
1070 ----------------
1072 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
1074 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
1076 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
1077 -- (not an OPERATOR_SYMBOL)
1079 -- The caller has already checked that the current token is <<
1081 -- Error recovery: can raise Error_Resync
1083 function P_Label return Node_Id is
1084 Label_Node : Node_Id;
1086 begin
1087 Label_Node := New_Node (N_Label, Token_Ptr);
1088 Scan; -- past <<
1089 Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
1090 T_Greater_Greater;
1091 Append_Elmt (Label_Node, Label_List);
1092 return Label_Node;
1093 end P_Label;
1095 -------------------------------
1096 -- 5.1 Statement Identifier --
1097 -------------------------------
1099 -- Statement label is parsed by P_Label (5.1)
1101 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
1102 -- or P_While_Statement (5.5)
1104 -- Block label is parsed by P_Begin_Statement (5.6) or
1105 -- P_Declare_Statement (5.6)
1107 -------------------------------
1108 -- 5.2 Assignment Statement --
1109 -------------------------------
1111 -- ASSIGNMENT_STATEMENT ::=
1112 -- variable_NAME := EXPRESSION;
1114 -- Error recovery: can raise Error_Resync
1116 function P_Assignment_Statement (LHS : Node_Id) return Node_Id is
1117 Assign_Node : Node_Id;
1119 begin
1120 Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr);
1121 Current_Assign_Node := Assign_Node;
1122 Set_Name (Assign_Node, LHS);
1123 Set_Expression (Assign_Node, P_Expression_No_Right_Paren);
1124 TF_Semicolon;
1125 Current_Assign_Node := Empty;
1126 return Assign_Node;
1127 end P_Assignment_Statement;
1129 -----------------------
1130 -- 5.3 If Statement --
1131 -----------------------
1133 -- IF_STATEMENT ::=
1134 -- if CONDITION then
1135 -- SEQUENCE_OF_STATEMENTS
1136 -- {elsif CONDITION then
1137 -- SEQUENCE_OF_STATEMENTS}
1138 -- [else
1139 -- SEQUENCE_OF_STATEMENTS]
1140 -- end if;
1142 -- The caller has checked that the initial token is IF (or in the error
1143 -- case of a mysterious THEN, the initial token may simply be THEN, in
1144 -- which case, no condition (or IF) was scanned).
1146 -- Error recovery: can raise Error_Resync
1148 function P_If_Statement return Node_Id is
1149 If_Node : Node_Id;
1150 Elsif_Node : Node_Id;
1151 Loc : Source_Ptr;
1153 procedure Add_Elsif_Part;
1154 -- An internal procedure used to scan out a single ELSIF part. On entry
1155 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
1156 -- scanned out and is in Prev_Token.
1158 procedure Check_If_Column;
1159 -- An internal procedure used to check that THEN, ELSE, or ELSIF
1160 -- appear in the right place if column checking is enabled (i.e. if
1161 -- they are the first token on the line, then they must appear in
1162 -- the same column as the opening IF).
1164 procedure Check_Then_Column;
1165 -- This procedure carries out the style checks for a THEN token
1166 -- Note that the caller has set Loc to the Source_Ptr value for
1167 -- the previous IF or ELSIF token.
1169 function Else_Should_Be_Elsif return Boolean;
1170 -- An internal routine used to do a special error recovery check when
1171 -- an ELSE is encountered. It determines if the ELSE should be treated
1172 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
1173 -- is followed by a sequence of tokens, starting on the same line as
1174 -- the ELSE, which are not expression terminators, followed by a THEN.
1175 -- On entry, the ELSE has been scanned out.
1177 procedure Add_Elsif_Part is
1178 begin
1179 if No (Elsif_Parts (If_Node)) then
1180 Set_Elsif_Parts (If_Node, New_List);
1181 end if;
1183 Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr);
1184 Loc := Prev_Token_Ptr;
1185 Set_Condition (Elsif_Node, P_Condition);
1186 Check_Then_Column;
1187 Then_Scan;
1188 Set_Then_Statements
1189 (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1190 Append (Elsif_Node, Elsif_Parts (If_Node));
1191 end Add_Elsif_Part;
1193 procedure Check_If_Column is
1194 begin
1195 if RM_Column_Check and then Token_Is_At_Start_Of_Line
1196 and then Start_Column /= Scopes (Scope.Last).Ecol
1197 then
1198 Error_Msg_Col := Scopes (Scope.Last).Ecol;
1199 Error_Msg_SC ("(style) this token should be@");
1200 end if;
1201 end Check_If_Column;
1203 procedure Check_Then_Column is
1204 begin
1205 if Token = Tok_Then then
1206 Check_If_Column;
1208 if Style_Check then
1209 Style.Check_Then (Loc);
1210 end if;
1211 end if;
1212 end Check_Then_Column;
1214 function Else_Should_Be_Elsif return Boolean is
1215 Scan_State : Saved_Scan_State;
1217 begin
1218 if Token_Is_At_Start_Of_Line then
1219 return False;
1221 else
1222 Save_Scan_State (Scan_State);
1224 loop
1225 if Token in Token_Class_Eterm then
1226 Restore_Scan_State (Scan_State);
1227 return False;
1228 else
1229 Scan; -- past non-expression terminating token
1231 if Token = Tok_Then then
1232 Restore_Scan_State (Scan_State);
1233 return True;
1234 end if;
1235 end if;
1236 end loop;
1237 end if;
1238 end Else_Should_Be_Elsif;
1240 -- Start of processing for P_If_Statement
1242 begin
1243 If_Node := New_Node (N_If_Statement, Token_Ptr);
1245 Push_Scope_Stack;
1246 Scopes (Scope.Last).Etyp := E_If;
1247 Scopes (Scope.Last).Ecol := Start_Column;
1248 Scopes (Scope.Last).Sloc := Token_Ptr;
1249 Scopes (Scope.Last).Labl := Error;
1250 Scopes (Scope.Last).Node := If_Node;
1252 if Token = Tok_If then
1253 Loc := Token_Ptr;
1254 Scan; -- past IF
1255 Set_Condition (If_Node, P_Condition);
1257 -- Deal with misuse of IF expression => used instead
1258 -- of WHEN expression =>
1260 if Token = Tok_Arrow then
1261 Error_Msg_SC -- CODEFIX
1262 ("THEN expected");
1263 Scan; -- past the arrow
1264 Pop_Scope_Stack; -- remove unneeded entry
1265 raise Error_Resync;
1266 end if;
1268 Check_Then_Column;
1270 else
1271 Error_Msg_SC ("no IF for this THEN");
1272 Set_Condition (If_Node, Error);
1273 end if;
1275 Then_Scan;
1277 Set_Then_Statements
1278 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1280 -- This loop scans out else and elsif parts
1282 loop
1283 if Token = Tok_Elsif then
1284 Check_If_Column;
1286 if Present (Else_Statements (If_Node)) then
1287 Error_Msg_SP ("ELSIF cannot appear after ELSE");
1288 end if;
1290 Scan; -- past ELSIF
1291 Add_Elsif_Part;
1293 elsif Token = Tok_Else then
1294 Check_If_Column;
1295 Scan; -- past ELSE
1297 if Else_Should_Be_Elsif then
1298 Error_Msg_SP -- CODEFIX
1299 ("ELSE should be ELSIF");
1300 Add_Elsif_Part;
1302 else
1303 -- Here we have an else that really is an else
1305 if Present (Else_Statements (If_Node)) then
1306 Error_Msg_SP ("only one ELSE part allowed");
1307 Append_List
1308 (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
1309 Else_Statements (If_Node));
1310 else
1311 Set_Else_Statements
1312 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
1313 end if;
1314 end if;
1316 -- If anything other than ELSE or ELSIF, exit the loop. The token
1317 -- had better be END (and in fact it had better be END IF), but
1318 -- we will let End_Statements take care of checking that.
1320 else
1321 exit;
1322 end if;
1323 end loop;
1325 End_Statements;
1326 return If_Node;
1328 end P_If_Statement;
1330 --------------------
1331 -- 5.3 Condition --
1332 --------------------
1334 -- CONDITION ::= boolean_EXPRESSION
1336 function P_Condition return Node_Id is
1337 begin
1338 return P_Condition (P_Expression_No_Right_Paren);
1339 end P_Condition;
1341 function P_Condition (Cond : Node_Id) return Node_Id is
1342 begin
1343 -- It is never possible for := to follow a condition, so if we get
1344 -- a := we assume it is a mistyped equality. Note that we do not try
1345 -- to reconstruct the tree correctly in this case, but we do at least
1346 -- give an accurate error message.
1348 if Token = Tok_Colon_Equal then
1349 while Token = Tok_Colon_Equal loop
1350 Error_Msg_SC -- CODEFIX
1351 (""":="" should be ""=""");
1352 Scan; -- past junk :=
1353 Discard_Junk_Node (P_Expression_No_Right_Paren);
1354 end loop;
1356 return Cond;
1358 -- Otherwise check for redundant parentheses but do not emit messages
1359 -- about expressions that require parentheses (e.g. conditional,
1360 -- quantified or declaration expressions).
1362 else
1363 if Style_Check
1364 and then
1365 Paren_Count (Cond) >
1366 (if Nkind (Cond) in N_Case_Expression
1367 | N_Expression_With_Actions
1368 | N_If_Expression
1369 | N_Quantified_Expression
1370 then 1
1371 else 0)
1372 then
1373 Style.Check_Xtra_Parens (First_Sloc (Cond));
1374 end if;
1376 -- And return the result
1378 return Cond;
1379 end if;
1380 end P_Condition;
1382 -------------------------
1383 -- 5.4 Case Statement --
1384 -------------------------
1386 -- CASE_STATEMENT ::=
1387 -- case EXPRESSION is
1388 -- CASE_STATEMENT_ALTERNATIVE
1389 -- {CASE_STATEMENT_ALTERNATIVE}
1390 -- end case;
1392 -- The caller has checked that the first token is CASE
1394 -- Can raise Error_Resync
1396 function P_Case_Statement return Node_Id is
1397 Case_Node : Node_Id;
1398 Alternatives_List : List_Id;
1399 First_When_Loc : Source_Ptr;
1401 begin
1402 Case_Node := New_Node (N_Case_Statement, Token_Ptr);
1404 Push_Scope_Stack;
1405 Scopes (Scope.Last).Etyp := E_Case;
1406 Scopes (Scope.Last).Ecol := Start_Column;
1407 Scopes (Scope.Last).Sloc := Token_Ptr;
1408 Scopes (Scope.Last).Labl := Error;
1409 Scopes (Scope.Last).Node := Case_Node;
1411 Scan; -- past CASE
1412 Set_Expression (Case_Node, P_Expression_No_Right_Paren);
1413 TF_Is;
1415 -- Prepare to parse case statement alternatives
1417 Alternatives_List := New_List;
1418 P_Pragmas_Opt (Alternatives_List);
1419 First_When_Loc := Token_Ptr;
1421 -- Loop through case statement alternatives
1423 loop
1424 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
1425 -- that it is a semantic check to ensure the proper use of OTHERS
1427 if Token in Tok_When | Tok_Others then
1428 Append (P_Case_Statement_Alternative, Alternatives_List);
1430 -- If we have an END, then probably we are at the end of the case
1431 -- but we only exit if Check_End thinks the END was reasonable.
1433 elsif Token = Tok_End then
1434 exit when Check_End;
1436 -- Here if token is other than WHEN, OTHERS or END. We definitely
1437 -- have an error, but the question is whether or not to get out of
1438 -- the case statement. We don't want to get out early, or we will
1439 -- get a slew of junk error messages for subsequent when tokens.
1441 -- If the token is not at the start of the line, or if it is indented
1442 -- with respect to the current case statement, then the best guess is
1443 -- that we are still supposed to be inside the case statement. We
1444 -- complain about the missing WHEN, and discard the junk statements.
1446 elsif not Token_Is_At_Start_Of_Line
1447 or else Start_Column > Scopes (Scope.Last).Ecol
1448 then
1449 Error_Msg_BC ("WHEN (case statement alternative) expected");
1451 -- Here is a possibility for infinite looping if we don't make
1452 -- progress. So try to process statements, otherwise exit
1454 declare
1455 Error_Ptr : constant Source_Ptr := Scan_Ptr;
1456 begin
1457 Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm));
1458 exit when Scan_Ptr = Error_Ptr and then Check_End;
1459 end;
1461 -- Here we have a junk token at the start of the line and it is
1462 -- not indented. If Check_End thinks there is a missing END, then
1463 -- we will get out of the case, otherwise we keep going.
1465 else
1466 exit when Check_End;
1467 end if;
1468 end loop;
1470 -- Make sure we have at least one alternative
1472 if No (First_Non_Pragma (Alternatives_List)) then
1473 Error_Msg
1474 ("WHEN expected, must have at least one alternative in case",
1475 First_When_Loc);
1476 return Error;
1478 else
1479 Set_Alternatives (Case_Node, Alternatives_List);
1480 return Case_Node;
1481 end if;
1482 end P_Case_Statement;
1484 -------------------------------------
1485 -- 5.4 Case Statement Alternative --
1486 -------------------------------------
1488 -- CASE_STATEMENT_ALTERNATIVE ::=
1489 -- when DISCRETE_CHOICE_LIST =>
1490 -- SEQUENCE_OF_STATEMENTS
1492 -- The caller has checked that the initial token is WHEN or OTHERS
1493 -- Error recovery: can raise Error_Resync
1495 function P_Case_Statement_Alternative return Node_Id is
1496 Case_Alt_Node : Node_Id;
1498 begin
1499 if Style_Check then
1500 Style.Check_Indentation;
1501 end if;
1503 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
1504 T_When; -- past WHEN (or give error in OTHERS case)
1505 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
1506 TF_Arrow;
1507 Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
1508 return Case_Alt_Node;
1509 end P_Case_Statement_Alternative;
1511 -------------------------
1512 -- 5.5 Loop Statement --
1513 -------------------------
1515 -- LOOP_STATEMENT ::=
1516 -- [LOOP_STATEMENT_IDENTIFIER:]
1517 -- [ITERATION_SCHEME] loop
1518 -- SEQUENCE_OF_STATEMENTS
1519 -- end loop [loop_IDENTIFIER];
1521 -- ITERATION_SCHEME ::=
1522 -- while CONDITION
1523 -- | for LOOP_PARAMETER_SPECIFICATION
1525 -- The parsing of loop statements is handled by one of three functions
1526 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
1527 -- on the initial keyword in the construct (excluding the identifier)
1529 -- P_Loop_Statement
1531 -- This function parses the case where no iteration scheme is present
1533 -- The caller has checked that the initial token is LOOP. The parameter
1534 -- is the node identifiers for the loop label if any (or is set to Empty
1535 -- if there is no loop label).
1537 -- Error recovery : cannot raise Error_Resync
1539 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1540 Loop_Node : Node_Id;
1541 Created_Name : Node_Id;
1543 begin
1544 Push_Scope_Stack;
1545 Scopes (Scope.Last).Labl := Loop_Name;
1546 Scopes (Scope.Last).Ecol := Start_Column;
1547 Scopes (Scope.Last).Sloc := Token_Ptr;
1548 Scopes (Scope.Last).Etyp := E_Loop;
1550 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1551 TF_Loop;
1553 if No (Loop_Name) then
1554 Created_Name :=
1555 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
1556 Set_Comes_From_Source (Created_Name, False);
1557 Set_Has_Created_Identifier (Loop_Node, True);
1558 Set_Identifier (Loop_Node, Created_Name);
1559 Scopes (Scope.Last).Labl := Created_Name;
1560 else
1561 Set_Identifier (Loop_Node, Loop_Name);
1562 end if;
1564 Append_Elmt (Loop_Node, Label_List);
1565 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1566 End_Statements (Loop_Node);
1567 return Loop_Node;
1568 end P_Loop_Statement;
1570 -- P_For_Statement
1572 -- This function parses a loop statement with a FOR iteration scheme
1574 -- The caller has checked that the initial token is FOR. The parameter
1575 -- is the node identifier for the block label if any (or is set to Empty
1576 -- if there is no block label).
1578 -- Note: the caller fills in the Identifier field if a label was present
1580 -- Error recovery: can raise Error_Resync
1582 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1583 Loop_Node : Node_Id;
1584 Iter_Scheme_Node : Node_Id;
1585 Loop_For_Flag : Boolean;
1586 Created_Name : Node_Id;
1587 Spec : Node_Id;
1589 begin
1590 Push_Scope_Stack;
1591 Scopes (Scope.Last).Labl := Loop_Name;
1592 Scopes (Scope.Last).Ecol := Start_Column;
1593 Scopes (Scope.Last).Sloc := Token_Ptr;
1594 Scopes (Scope.Last).Etyp := E_Loop;
1596 Loop_For_Flag := (Prev_Token = Tok_Loop);
1597 Scan; -- past FOR
1598 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1599 Spec := P_Loop_Parameter_Specification;
1601 if Nkind (Spec) = N_Loop_Parameter_Specification then
1602 Set_Loop_Parameter_Specification (Iter_Scheme_Node, Spec);
1603 else
1604 Set_Iterator_Specification (Iter_Scheme_Node, Spec);
1605 end if;
1607 -- The following is a special test so that a miswritten for loop such
1608 -- as "loop for I in 1..10;" is handled nicely, without making an extra
1609 -- entry in the scope stack. We don't bother to actually fix up the
1610 -- tree in this case since it's not worth the effort. Instead we just
1611 -- eat up the loop junk, leaving the entry for what now looks like an
1612 -- unmodified loop intact.
1614 if Loop_For_Flag and then Token = Tok_Semicolon then
1615 Error_Msg_SC ("LOOP belongs here, not before FOR");
1616 Pop_Scope_Stack;
1617 return Error;
1619 -- Normal case
1621 else
1622 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1624 if No (Loop_Name) then
1625 Created_Name :=
1626 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
1627 Set_Comes_From_Source (Created_Name, False);
1628 Set_Has_Created_Identifier (Loop_Node, True);
1629 Set_Identifier (Loop_Node, Created_Name);
1630 Scopes (Scope.Last).Labl := Created_Name;
1631 else
1632 Set_Identifier (Loop_Node, Loop_Name);
1633 end if;
1635 TF_Loop;
1636 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1637 End_Statements (Loop_Node);
1638 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1639 Append_Elmt (Loop_Node, Label_List);
1640 return Loop_Node;
1641 end if;
1642 end P_For_Statement;
1644 -- P_While_Statement
1646 -- This procedure scans a loop statement with a WHILE iteration scheme
1648 -- The caller has checked that the initial token is WHILE. The parameter
1649 -- is the node identifier for the block label if any (or is set to Empty
1650 -- if there is no block label).
1652 -- Error recovery: cannot raise Error_Resync
1654 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
1655 Loop_Node : Node_Id;
1656 Iter_Scheme_Node : Node_Id;
1657 Loop_While_Flag : Boolean;
1658 Created_Name : Node_Id;
1660 begin
1661 Push_Scope_Stack;
1662 Scopes (Scope.Last).Labl := Loop_Name;
1663 Scopes (Scope.Last).Ecol := Start_Column;
1664 Scopes (Scope.Last).Sloc := Token_Ptr;
1665 Scopes (Scope.Last).Etyp := E_Loop;
1667 Loop_While_Flag := (Prev_Token = Tok_Loop);
1668 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
1669 Scan; -- past WHILE
1670 Set_Condition (Iter_Scheme_Node, P_Condition);
1672 -- The following is a special test so that a miswritten for loop such
1673 -- as "loop while I > 10;" is handled nicely, without making an extra
1674 -- entry in the scope stack. We don't bother to actually fix up the
1675 -- tree in this case since it's not worth the effort. Instead we just
1676 -- eat up the loop junk, leaving the entry for what now looks like an
1677 -- unmodified loop intact.
1679 if Loop_While_Flag and then Token = Tok_Semicolon then
1680 Error_Msg_SC ("LOOP belongs here, not before WHILE");
1681 Pop_Scope_Stack;
1682 return Error;
1684 -- Normal case
1686 else
1687 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
1688 TF_Loop;
1690 if No (Loop_Name) then
1691 Created_Name :=
1692 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
1693 Set_Comes_From_Source (Created_Name, False);
1694 Set_Has_Created_Identifier (Loop_Node, True);
1695 Set_Identifier (Loop_Node, Created_Name);
1696 Scopes (Scope.Last).Labl := Created_Name;
1697 else
1698 Set_Identifier (Loop_Node, Loop_Name);
1699 end if;
1701 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
1702 End_Statements (Loop_Node);
1703 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
1704 Append_Elmt (Loop_Node, Label_List);
1705 return Loop_Node;
1706 end if;
1707 end P_While_Statement;
1709 ---------------------------------------
1710 -- 5.5 Loop Parameter Specification --
1711 ---------------------------------------
1713 -- LOOP_PARAMETER_SPECIFICATION ::=
1714 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
1715 -- [Iterator_Filter]
1717 -- Error recovery: cannot raise Error_Resync
1719 function P_Loop_Parameter_Specification return Node_Id is
1720 Loop_Param_Specification_Node : Node_Id;
1722 ID_Node : Node_Id;
1723 Scan_State : Saved_Scan_State;
1725 begin
1727 Save_Scan_State (Scan_State);
1728 ID_Node := P_Defining_Identifier (C_In);
1730 -- If the next token is OF, it indicates an Ada 2012 iterator. If the
1731 -- next token is a colon, this is also an Ada 2012 iterator, including
1732 -- a subtype indication for the loop parameter. Otherwise we parse the
1733 -- construct as a loop parameter specification. Note that the form
1734 -- "for A in B" is ambiguous, and must be resolved semantically: if B
1735 -- is a discrete subtype this is a loop specification, but if it is an
1736 -- expression it is an iterator specification. Ambiguity is resolved
1737 -- during analysis of the loop parameter specification.
1739 if Token in Tok_Of | Tok_Colon then
1740 Error_Msg_Ada_2012_Feature ("iterator", Token_Ptr);
1741 return P_Iterator_Specification (ID_Node);
1742 end if;
1744 -- The span of the Loop_Parameter_Specification starts at the
1745 -- defining identifier.
1747 Loop_Param_Specification_Node :=
1748 New_Node (N_Loop_Parameter_Specification, Sloc (ID_Node));
1749 Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
1751 if Token = Tok_Left_Paren then
1752 Error_Msg_SC ("subscripted loop parameter not allowed");
1753 Restore_Scan_State (Scan_State);
1754 Discard_Junk_Node (P_Name);
1756 elsif Token = Tok_Dot then
1757 Error_Msg_SC ("selected loop parameter not allowed");
1758 Restore_Scan_State (Scan_State);
1759 Discard_Junk_Node (P_Name);
1760 end if;
1762 T_In;
1764 if Token = Tok_Reverse then
1765 Scan; -- past REVERSE
1766 Set_Reverse_Present (Loop_Param_Specification_Node, True);
1767 end if;
1769 Set_Discrete_Subtype_Definition
1770 (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
1772 if Token = Tok_When then
1773 Error_Msg_Ada_2022_Feature ("iterator filter", Token_Ptr);
1775 Scan; -- past WHEN
1776 Set_Iterator_Filter
1777 (Loop_Param_Specification_Node, P_Condition);
1778 end if;
1780 return Loop_Param_Specification_Node;
1782 exception
1783 when Error_Resync =>
1784 return Error;
1785 end P_Loop_Parameter_Specification;
1787 ----------------------------------
1788 -- 5.5.1 Iterator_Specification --
1789 ----------------------------------
1791 function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id is
1792 Node1 : Node_Id;
1794 begin
1795 Node1 := New_Node (N_Iterator_Specification, Sloc (Def_Id));
1796 Set_Defining_Identifier (Node1, Def_Id);
1798 if Token = Tok_Colon then
1799 Scan; -- past :
1801 if Token = Tok_Access then
1802 Error_Msg_Ada_2022_Feature
1803 ("access definition in loop parameter", Token_Ptr);
1804 Set_Subtype_Indication (Node1, P_Access_Definition (False));
1806 else
1807 Set_Subtype_Indication (Node1, P_Subtype_Indication);
1808 end if;
1809 end if;
1811 if Token = Tok_Of then
1812 Set_Of_Present (Node1);
1813 Scan; -- past OF
1815 elsif Token = Tok_In then
1816 Scan; -- past IN
1818 elsif Prev_Token = Tok_In
1819 and then Present (Subtype_Indication (Node1))
1820 then
1821 -- Simplest recovery is to transform it into an element iterator.
1822 -- Error message on 'in" has already been emitted when parsing the
1823 -- optional constraint.
1825 Set_Of_Present (Node1);
1826 Error_Msg_N
1827 ("subtype indication is only legal on an element iterator",
1828 Subtype_Indication (Node1));
1830 else
1831 return Error;
1832 end if;
1834 if Token = Tok_Reverse then
1835 Scan; -- past REVERSE
1836 Set_Reverse_Present (Node1, True);
1837 end if;
1839 Set_Name (Node1, P_Name);
1841 if Token = Tok_When then
1842 Error_Msg_Ada_2022_Feature ("iterator filter", Token_Ptr);
1844 Scan; -- past WHEN
1845 Set_Iterator_Filter
1846 (Node1, P_Condition);
1847 end if;
1849 return Node1;
1850 end P_Iterator_Specification;
1852 --------------------------
1853 -- 5.6 Block Statement --
1854 --------------------------
1856 -- BLOCK_STATEMENT ::=
1857 -- [block_STATEMENT_IDENTIFIER:]
1858 -- [declare
1859 -- DECLARATIVE_PART]
1860 -- begin
1861 -- HANDLED_SEQUENCE_OF_STATEMENTS
1862 -- end [block_IDENTIFIER];
1864 -- The parsing of block statements is handled by one of the two functions
1865 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
1866 -- a declare section is present
1868 -- P_Declare_Statement
1870 -- This function parses a block statement with DECLARE present
1872 -- The caller has checked that the initial token is DECLARE
1874 -- Error recovery: cannot raise Error_Resync
1876 function P_Declare_Statement
1877 (Block_Name : Node_Id := Empty)
1878 return Node_Id
1880 Block_Node : Node_Id;
1881 Created_Name : Node_Id;
1883 begin
1884 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1886 Push_Scope_Stack;
1887 Scopes (Scope.Last).Etyp := E_Name;
1888 Scopes (Scope.Last).Lreq := Present (Block_Name);
1889 Scopes (Scope.Last).Ecol := Start_Column;
1890 Scopes (Scope.Last).Labl := Block_Name;
1891 Scopes (Scope.Last).Sloc := Token_Ptr;
1893 Scan; -- past DECLARE
1895 if No (Block_Name) then
1896 Created_Name :=
1897 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
1898 Set_Comes_From_Source (Created_Name, False);
1899 Set_Has_Created_Identifier (Block_Node, True);
1900 Set_Identifier (Block_Node, Created_Name);
1901 Scopes (Scope.Last).Labl := Created_Name;
1902 else
1903 Set_Identifier (Block_Node, Block_Name);
1904 end if;
1906 Append_Elmt (Block_Node, Label_List);
1907 Parse_Decls_Begin_End (Block_Node);
1908 return Block_Node;
1909 end P_Declare_Statement;
1911 -- P_Begin_Statement
1913 -- This function parses a block statement with no DECLARE present
1915 -- The caller has checked that the initial token is BEGIN
1917 -- Error recovery: cannot raise Error_Resync
1919 function P_Begin_Statement
1920 (Block_Name : Node_Id := Empty)
1921 return Node_Id
1923 Block_Node : Node_Id;
1924 Created_Name : Node_Id;
1926 begin
1927 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
1929 Push_Scope_Stack;
1930 Scopes (Scope.Last).Etyp := E_Name;
1931 Scopes (Scope.Last).Lreq := Present (Block_Name);
1932 Scopes (Scope.Last).Ecol := Start_Column;
1933 Scopes (Scope.Last).Labl := Block_Name;
1934 Scopes (Scope.Last).Sloc := Token_Ptr;
1936 if No (Block_Name) then
1937 Created_Name :=
1938 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
1939 Set_Comes_From_Source (Created_Name, False);
1940 Set_Has_Created_Identifier (Block_Node, True);
1941 Set_Identifier (Block_Node, Created_Name);
1942 Scopes (Scope.Last).Labl := Created_Name;
1943 else
1944 Set_Identifier (Block_Node, Block_Name);
1945 end if;
1947 Append_Elmt (Block_Node, Label_List);
1949 Scopes (Scope.Last).Ecol := Start_Column;
1950 Scopes (Scope.Last).Sloc := Token_Ptr;
1951 Scan; -- past BEGIN
1952 Set_Handled_Statement_Sequence
1953 (Block_Node, P_Handled_Sequence_Of_Statements);
1954 End_Statements (Handled_Statement_Sequence (Block_Node));
1955 return Block_Node;
1956 end P_Begin_Statement;
1958 -------------------------
1959 -- 5.7 Exit Statement --
1960 -------------------------
1962 -- EXIT_STATEMENT ::=
1963 -- exit [loop_NAME] [when CONDITION];
1965 -- The caller has checked that the initial token is EXIT
1967 -- Error recovery: can raise Error_Resync
1969 function P_Exit_Statement return Node_Id is
1970 Exit_Node : Node_Id;
1972 -- Start of processing for P_Exit_Statement
1974 begin
1975 Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
1976 Scan; -- past EXIT
1978 if Token = Tok_Identifier then
1979 Set_Name (Exit_Node, P_Qualified_Simple_Name);
1981 elsif Style_Check then
1982 -- This EXIT has no name, so check that
1983 -- the innermost loop is unnamed too.
1985 Check_No_Exit_Name :
1986 for J in reverse 1 .. Scope.Last loop
1987 if Scopes (J).Etyp = E_Loop then
1988 if Present (Scopes (J).Labl)
1989 and then Comes_From_Source (Scopes (J).Labl)
1990 then
1991 -- Innermost loop in fact had a name, style check fails
1993 Style.No_Exit_Name (Scopes (J).Labl);
1994 end if;
1996 exit Check_No_Exit_Name;
1997 end if;
1998 end loop Check_No_Exit_Name;
1999 end if;
2001 if Token = Tok_When and then not Missing_Semicolon_On_When then
2002 Scan; -- past WHEN
2003 Set_Condition (Exit_Node, P_Condition);
2005 -- Allow IF instead of WHEN, giving error message
2007 elsif Token = Tok_If then
2008 T_When;
2009 Scan; -- past IF used in place of WHEN
2010 Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
2011 end if;
2013 TF_Semicolon;
2014 return Exit_Node;
2015 end P_Exit_Statement;
2017 -------------------------
2018 -- 5.8 Goto Statement --
2019 -------------------------
2021 -- GOTO_STATEMENT ::= goto label_NAME;
2023 -- The caller has checked that the initial token is GOTO (or TO in the
2024 -- error case where GO and TO were incorrectly separated).
2026 -- Error recovery: can raise Error_Resync
2028 function P_Goto_Statement return Node_Id is
2029 Goto_Node : Node_Id;
2031 begin
2032 Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
2033 Scan; -- past GOTO (or TO)
2034 Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
2035 Append_Elmt (Goto_Node, Goto_List);
2037 if Token = Tok_When then
2038 Error_Msg_GNAT_Extension ("goto when statement", Token_Ptr);
2040 Scan; -- past WHEN
2041 Mutate_Nkind (Goto_Node, N_Goto_When_Statement);
2042 Set_Condition (Goto_Node, P_Expression_No_Right_Paren);
2043 end if;
2045 TF_Semicolon;
2046 return Goto_Node;
2047 end P_Goto_Statement;
2049 ---------------------------
2050 -- Parse_Decls_Begin_End --
2051 ---------------------------
2053 -- This function parses the construct:
2055 -- DECLARATIVE_PART
2056 -- begin
2057 -- HANDLED_SEQUENCE_OF_STATEMENTS
2058 -- end [NAME];
2060 -- The caller has built the scope stack entry, and created the node to
2061 -- whose Declarations and Handled_Statement_Sequence fields are to be
2062 -- set. On return these fields are filled in (except in the case of a
2063 -- task body, where the handled statement sequence is optional, and may
2064 -- thus be Empty), and the scan is positioned past the End sequence.
2066 -- If the BEGIN is missing, then the parent node is used to help construct
2067 -- an appropriate missing BEGIN message. Possibilities for the parent are:
2069 -- N_Block_Statement declare block
2070 -- N_Entry_Body entry body
2071 -- N_Package_Body package body (begin part optional)
2072 -- N_Subprogram_Body procedure or function body
2073 -- N_Task_Body task body
2075 -- Note: in the case of a block statement, there is definitely a DECLARE
2076 -- present (because a Begin statement without a DECLARE is handled by the
2077 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
2079 -- Error recovery: cannot raise Error_Resync
2081 procedure Parse_Decls_Begin_End (Parent : Node_Id) is
2082 Body_Decl : Node_Id;
2083 Decls : List_Id;
2084 Parent_Nkind : Node_Kind;
2085 Spec_Node : Node_Id;
2086 HSS : Node_Id;
2088 procedure Missing_Begin (Msg : String);
2089 -- Called to post a missing begin message. In the normal case this is
2090 -- posted at the start of the current token. A special case arises when
2091 -- P_Declarative_Items has previously found a missing begin, in which
2092 -- case we replace the original error message.
2094 procedure Set_Null_HSS (Parent : Node_Id);
2095 -- Construct an empty handled statement sequence and install in Parent
2096 -- Leaves HSS set to reference the newly constructed statement sequence.
2098 -------------------
2099 -- Missing_Begin --
2100 -------------------
2102 procedure Missing_Begin (Msg : String) is
2103 begin
2104 if Missing_Begin_Msg = No_Error_Msg then
2105 Error_Msg_BC (Msg);
2106 else
2107 Change_Error_Text (Missing_Begin_Msg, Msg);
2109 -- Purge any messages issued after than, since a missing begin
2110 -- can cause a lot of havoc, and it is better not to dump these
2111 -- cascaded messages on the user.
2113 Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
2114 end if;
2115 end Missing_Begin;
2117 ------------------
2118 -- Set_Null_HSS --
2119 ------------------
2121 procedure Set_Null_HSS (Parent : Node_Id) is
2122 Null_Stm : Node_Id;
2124 begin
2125 Null_Stm :=
2126 Make_Null_Statement (Token_Ptr);
2127 Set_Comes_From_Source (Null_Stm, False);
2129 HSS :=
2130 Make_Handled_Sequence_Of_Statements (Token_Ptr,
2131 Statements => New_List (Null_Stm));
2132 Set_Comes_From_Source (HSS, False);
2134 Set_Handled_Statement_Sequence (Parent, HSS);
2135 end Set_Null_HSS;
2137 -- Start of processing for Parse_Decls_Begin_End
2139 begin
2140 Decls := P_Declarative_Part;
2142 if Ada_Version = Ada_83 then
2143 Check_Later_Vs_Basic_Declarations (Decls, During_Parsing => True);
2144 end if;
2146 -- Here is where we deal with the case of IS used instead of semicolon.
2147 -- Specifically, if the last declaration in the declarative part is a
2148 -- subprogram body still marked as having a bad IS, then this is where
2149 -- we decide that the IS should really have been a semicolon and that
2150 -- the body should have been a declaration. Note that if the bad IS
2151 -- had turned out to be OK (i.e. a decent begin/end was found for it),
2152 -- then the Bad_Is_Detected flag would have been reset by now.
2154 Body_Decl := Last (Decls);
2156 if Present (Body_Decl)
2157 and then Nkind (Body_Decl) = N_Subprogram_Body
2158 and then Bad_Is_Detected (Body_Decl)
2159 then
2160 -- OK, we have the case of a bad IS, so we need to fix up the tree.
2161 -- What we have now is a subprogram body with attached declarations
2162 -- and a possible statement sequence.
2164 -- First step is to take the declarations that were part of the bogus
2165 -- subprogram body and append them to the outer declaration chain.
2166 -- In other words we append them past the body (which we will later
2167 -- convert into a declaration).
2169 Append_List (Declarations (Body_Decl), Decls);
2171 -- Now take the handled statement sequence of the bogus body and
2172 -- set it as the statement sequence for the outer construct. Note
2173 -- that it may be empty (we specially allowed a missing BEGIN for
2174 -- a subprogram body marked as having a bad IS -- see below).
2176 Set_Handled_Statement_Sequence (Parent,
2177 Handled_Statement_Sequence (Body_Decl));
2179 -- Next step is to convert the old body node to a declaration node
2181 Spec_Node := Specification (Body_Decl);
2182 Change_Node (Body_Decl, N_Subprogram_Declaration);
2183 Set_Specification (Body_Decl, Spec_Node);
2185 -- Final step is to put the declarations for the parent where
2186 -- they belong, and then fall through the IF to scan out the
2187 -- END statements.
2189 Set_Declarations (Parent, Decls);
2191 -- This is the normal case (i.e. any case except the bad IS case)
2192 -- If we have a BEGIN, then scan out the sequence of statements, and
2193 -- also reset the expected column for the END to match the BEGIN.
2195 else
2196 Set_Declarations (Parent, Decls);
2198 if Token = Tok_Begin then
2199 if Style_Check then
2200 Style.Check_Indentation;
2201 end if;
2203 Error_Msg_Col := Scopes (Scope.Last).Ecol;
2205 if RM_Column_Check
2206 and then Token_Is_At_Start_Of_Line
2207 and then Start_Column /= Error_Msg_Col
2208 then
2209 Error_Msg_SC ("(style) BEGIN in wrong column, should be@");
2211 else
2212 Scopes (Scope.Last).Ecol := Start_Column;
2213 end if;
2215 Scopes (Scope.Last).Sloc := Token_Ptr;
2216 Scan; -- past BEGIN
2217 Set_Handled_Statement_Sequence (Parent,
2218 P_Handled_Sequence_Of_Statements);
2220 -- No BEGIN present
2222 else
2223 Parent_Nkind := Nkind (Parent);
2225 -- A special check for the missing IS case. If we have a
2226 -- subprogram body that was marked as having a suspicious
2227 -- IS, and the current token is END, then we simply confirm
2228 -- the suspicion, and do not require a BEGIN to be present
2230 if Parent_Nkind = N_Subprogram_Body
2231 and then Token = Tok_End
2232 and then Scopes (Scope.Last).Etyp = E_Suspicious_Is
2233 then
2234 Scopes (Scope.Last).Etyp := E_Bad_Is;
2236 -- Otherwise BEGIN is not required for a package body, so we
2237 -- don't mind if it is missing, but we do construct a dummy
2238 -- one (so that we have somewhere to set End_Label).
2240 -- However if we have something other than a BEGIN which
2241 -- looks like it might be statements, then we signal a missing
2242 -- BEGIN for these cases as well. We define "something which
2243 -- looks like it might be statements" as a token other than
2244 -- END, EOF, or a token which starts declarations.
2246 elsif Parent_Nkind = N_Package_Body
2247 and then (Token in Tok_End | Tok_EOF | Token_Class_Declk)
2248 then
2249 Set_Null_HSS (Parent);
2251 -- These are cases in which a BEGIN is required and not present
2253 else
2254 Set_Null_HSS (Parent);
2256 -- Prepare to issue error message
2258 Error_Msg_Sloc := Scopes (Scope.Last).Sloc;
2259 Error_Msg_Node_1 := Scopes (Scope.Last).Labl;
2261 -- Now issue appropriate message
2263 if Parent_Nkind = N_Block_Statement then
2264 Missing_Begin ("missing BEGIN for DECLARE#!");
2266 elsif Parent_Nkind = N_Entry_Body then
2267 Missing_Begin ("missing BEGIN for ENTRY#!");
2269 elsif Parent_Nkind = N_Subprogram_Body then
2270 if Nkind (Specification (Parent))
2271 = N_Function_Specification
2272 then
2273 Missing_Begin ("missing BEGIN for function&#!");
2274 else
2275 Missing_Begin ("missing BEGIN for procedure&#!");
2276 end if;
2278 -- The case for package body arises only when
2279 -- we have possible statement junk present.
2281 elsif Parent_Nkind = N_Package_Body then
2282 Missing_Begin ("missing BEGIN for package body&#!");
2284 else
2285 pragma Assert (Parent_Nkind = N_Task_Body);
2286 Missing_Begin ("missing BEGIN for task body&#!");
2287 end if;
2289 -- Here we pick up the statements after the BEGIN that
2290 -- should have been present but was not. We don't insist
2291 -- on statements being present if P_Declarative_Part had
2292 -- already found a missing BEGIN, since it might have
2293 -- swallowed a lone statement into the declarative part.
2295 if Missing_Begin_Msg /= No_Error_Msg
2296 and then Token = Tok_End
2297 then
2298 null;
2299 else
2300 Set_Handled_Statement_Sequence (Parent,
2301 P_Handled_Sequence_Of_Statements);
2302 end if;
2303 end if;
2304 end if;
2305 end if;
2307 -- Here with declarations and handled statement sequence scanned
2309 if Present (Handled_Statement_Sequence (Parent)) then
2310 End_Statements (Handled_Statement_Sequence (Parent));
2311 else
2312 End_Statements;
2313 end if;
2315 -- We know that End_Statements removed an entry from the scope stack
2316 -- (because it is required to do so under all circumstances). We can
2317 -- therefore reference the entry it removed one past the stack top.
2318 -- What we are interested in is whether it was a case of a bad IS.
2319 -- We can't call Scopes here.
2321 if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
2322 Error_Msg -- CODEFIX
2323 ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
2324 Set_Bad_Is_Detected (Parent, True);
2325 end if;
2327 end Parse_Decls_Begin_End;
2329 -------------------------
2330 -- Set_Loop_Block_Name --
2331 -------------------------
2333 function Set_Loop_Block_Name (L : Character) return Name_Id is
2334 begin
2335 Name_Buffer (1) := L;
2336 Name_Buffer (2) := '_';
2337 Name_Len := 2;
2338 Loop_Block_Count := Loop_Block_Count + 1;
2339 Add_Nat_To_Name_Buffer (Loop_Block_Count);
2340 return Name_Find;
2341 end Set_Loop_Block_Name;
2343 ---------------
2344 -- Then_Scan --
2345 ---------------
2347 procedure Then_Scan is
2348 begin
2349 TF_Then;
2351 while Token = Tok_Then loop
2352 Error_Msg_SC -- CODEFIX
2353 ("redundant THEN");
2354 TF_Then;
2355 end loop;
2357 if Token in Tok_And | Tok_Or then
2358 Error_Msg_SC ("unexpected logical operator");
2359 Scan; -- past logical operator
2361 if (Prev_Token = Tok_And and then Token = Tok_Then)
2362 or else
2363 (Prev_Token = Tok_Or and then Token = Tok_Else)
2364 then
2365 Scan;
2366 end if;
2368 Discard_Junk_Node (P_Expression);
2369 end if;
2371 if Token = Tok_Then then
2372 Scan;
2373 end if;
2374 end Then_Scan;
2376 end Ch5;