|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- P A R . C H 5 --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 pragma Style_Checks (All_Checks);
|
|
|
27 -- Turn off subprogram body ordering check. Subprograms are in order by RM
|
|
|
28 -- section rather than alphabetical.
|
|
|
29
|
|
|
30 with Sinfo.CN; use Sinfo.CN;
|
|
|
31
|
|
|
32 separate (Par)
|
|
|
33 package body Ch5 is
|
|
|
34
|
|
|
35 -- Local functions, used only in this chapter
|
|
|
36
|
|
|
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;
|
|
|
44
|
|
|
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).
|
|
|
49
|
|
|
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.
|
|
|
54
|
|
|
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.
|
|
|
59
|
|
|
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.
|
|
|
64
|
|
|
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.
|
|
|
69
|
|
|
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.
|
|
|
74
|
|
|
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.
|
|
|
79
|
|
|
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.
|
|
|
84
|
|
|
85 procedure Then_Scan;
|
|
|
86 -- Scan past THEN token, testing for illegal junk after it
|
|
|
87
|
|
|
88 ---------------------------------
|
|
|
89 -- 5.1 Sequence of Statements --
|
|
|
90 ---------------------------------
|
|
|
91
|
|
|
92 -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} {LABEL}
|
|
|
93 -- Note: the final label is an Ada 2012 addition.
|
|
|
94
|
|
|
95 -- STATEMENT ::=
|
|
|
96 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
|
|
|
97
|
|
|
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
|
|
|
105
|
|
|
106 -- COMPOUND_STATEMENT ::=
|
|
|
107 -- IF_STATEMENT | CASE_STATEMENT
|
|
|
108 -- | LOOP_STATEMENT | BLOCK_STATEMENT
|
|
|
109 -- | ACCEPT_STATEMENT | SELECT_STATEMENT
|
|
|
110
|
|
|
111 -- This procedure scans a sequence of statements. The caller sets SS_Flags
|
|
|
112 -- to indicate acceptable termination conditions for the sequence:
|
|
|
113
|
|
|
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
|
|
|
121
|
|
|
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:
|
|
|
126
|
|
|
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.
|
|
|
131
|
|
|
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.
|
|
|
136
|
|
|
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.
|
|
|
140
|
|
|
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)
|
|
|
147
|
|
|
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.
|
|
|
151
|
|
|
152 function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is
|
|
|
153
|
|
|
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.
|
|
|
160
|
|
|
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.
|
|
|
165
|
|
|
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.
|
|
|
170
|
|
|
171 Scan_State_Label : Saved_Scan_State;
|
|
|
172 Scan_State : Saved_Scan_State;
|
|
|
173
|
|
|
174 Statement_List : List_Id;
|
|
|
175 Block_Label : Name_Id;
|
|
|
176 Id_Node : Node_Id;
|
|
|
177 Name_Node : Node_Id;
|
|
|
178
|
|
|
179 procedure Junk_Declaration;
|
|
|
180 -- Procedure called to handle error of declaration encountered in
|
|
|
181 -- statement sequence.
|
|
|
182
|
|
|
183 procedure Test_Statement_Required;
|
|
|
184 -- Flag error if Statement_Required flag set
|
|
|
185
|
|
|
186 ----------------------
|
|
|
187 -- Junk_Declaration --
|
|
|
188 ----------------------
|
|
|
189
|
|
|
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;
|
|
|
197
|
|
|
198 Skip_Declaration (Statement_List);
|
|
|
199 end Junk_Declaration;
|
|
|
200
|
|
|
201 -----------------------------
|
|
|
202 -- Test_Statement_Required --
|
|
|
203 -----------------------------
|
|
|
204
|
|
|
205 procedure Test_Statement_Required is
|
|
|
206 function All_Pragmas return Boolean;
|
|
|
207 -- Return True if statement list is all pragmas
|
|
|
208
|
|
|
209 -----------------
|
|
|
210 -- All_Pragmas --
|
|
|
211 -----------------
|
|
|
212
|
|
|
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;
|
|
|
224
|
|
|
225 return True;
|
|
|
226 end All_Pragmas;
|
|
|
227
|
|
|
228 -- Start of processing for Test_Statement_Required
|
|
|
229
|
|
|
230 begin
|
|
|
231 if Statement_Required then
|
|
|
232
|
|
|
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.
|
|
|
235
|
|
|
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
|
|
|
244
|
|
|
245 Check_Compiler_Unit ("null statement list", Token_Ptr);
|
|
|
246
|
|
|
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;
|
|
|
254
|
|
|
255 -- If not Ada 2012, or not special case above, give error message
|
|
|
256
|
|
|
257 else
|
|
|
258 Error_Msg_BC -- CODEFIX
|
|
|
259 ("statement expected");
|
|
|
260 end if;
|
|
|
261 end if;
|
|
|
262 end Test_Statement_Required;
|
|
|
263
|
|
|
264 -- Start of processing for P_Sequence_Of_Statements
|
|
|
265
|
|
|
266 begin
|
|
|
267 Statement_List := New_List;
|
|
|
268 Statement_Required := SS_Flags.Sreq;
|
|
|
269 Statement_Seen := False;
|
|
|
270
|
|
|
271 loop
|
|
|
272 Ignore (Tok_Semicolon);
|
|
|
273
|
|
|
274 begin
|
|
|
275 if Style_Check then
|
|
|
276 Style.Check_Indentation;
|
|
|
277 end if;
|
|
|
278
|
|
|
279 -- Deal with reserved identifier (in assignment or call)
|
|
|
280
|
|
|
281 if Is_Reserved_Identifier then
|
|
|
282 Save_Scan_State (Scan_State); -- at possible bad identifier
|
|
|
283 Scan; -- and scan past it
|
|
|
284
|
|
|
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.
|
|
|
288
|
|
|
289 if
|
|
|
290 -- If followed by a semicolon, then it is an identifier,
|
|
|
291 -- with the exception of the cases tested for below.
|
|
|
292
|
|
|
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)
|
|
|
299
|
|
|
300 -- If followed by colon, colon-equal, or dot, then we
|
|
|
301 -- definitely have an identifier (could not be reserved)
|
|
|
302
|
|
|
303 or else Token = Tok_Colon
|
|
|
304 or else Token = Tok_Colon_Equal
|
|
|
305 or else Token = Tok_Dot
|
|
|
306
|
|
|
307 -- Left paren means we have an identifier except for those
|
|
|
308 -- reserved words that can legitimately be followed by a
|
|
|
309 -- left paren.
|
|
|
310
|
|
|
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.
|
|
|
327
|
|
|
328 Restore_Scan_State (Scan_State); -- back to the ID
|
|
|
329 Scan_Reserved_Identifier (Force_Msg => False);
|
|
|
330
|
|
|
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.
|
|
|
333
|
|
|
334 else
|
|
|
335 Restore_Scan_State (Scan_State); -- back to the reserved word
|
|
|
336 end if;
|
|
|
337 end if;
|
|
|
338
|
|
|
339 -- Now look to see what kind of statement we have
|
|
|
340
|
|
|
341 case Token is
|
|
|
342
|
|
|
343 -- Case of end or EOF
|
|
|
344
|
|
|
345 when Tok_End
|
|
|
346 | Tok_EOF
|
|
|
347 =>
|
|
|
348 -- These tokens always terminate the statement sequence
|
|
|
349
|
|
|
350 Test_Statement_Required;
|
|
|
351 exit;
|
|
|
352
|
|
|
353 -- Case of ELSIF
|
|
|
354
|
|
|
355 when Tok_Elsif =>
|
|
|
356
|
|
|
357 -- Terminate if Eftm set or if the ELSIF is to the left
|
|
|
358 -- of the expected column of the end for this sequence
|
|
|
359
|
|
|
360 if SS_Flags.Eftm
|
|
|
361 or else Start_Column < Scope.Table (Scope.Last).Ecol
|
|
|
362 then
|
|
|
363 Test_Statement_Required;
|
|
|
364 exit;
|
|
|
365
|
|
|
366 -- Otherwise complain and skip past ELSIF Condition then
|
|
|
367
|
|
|
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;
|
|
|
375
|
|
|
376 -- Case of ELSE
|
|
|
377
|
|
|
378 when Tok_Else =>
|
|
|
379
|
|
|
380 -- Terminate if Eltm set or if the else is to the left
|
|
|
381 -- of the expected column of the end for this sequence
|
|
|
382
|
|
|
383 if SS_Flags.Eltm
|
|
|
384 or else Start_Column < Scope.Table (Scope.Last).Ecol
|
|
|
385 then
|
|
|
386 Test_Statement_Required;
|
|
|
387 exit;
|
|
|
388
|
|
|
389 -- Otherwise complain and skip past else
|
|
|
390
|
|
|
391 else
|
|
|
392 Error_Msg_SC ("ELSE not allowed here");
|
|
|
393 Scan; -- past ELSE
|
|
|
394 Statement_Required := False;
|
|
|
395 end if;
|
|
|
396
|
|
|
397 -- Case of exception
|
|
|
398
|
|
|
399 when Tok_Exception =>
|
|
|
400 Test_Statement_Required;
|
|
|
401
|
|
|
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.
|
|
|
406
|
|
|
407 if not SS_Flags.Extm and then
|
|
|
408 Start_Column >= Scope.Table (Scope.Last).Ecol
|
|
|
409
|
|
|
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;
|
|
|
415
|
|
|
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.
|
|
|
419
|
|
|
420 exit;
|
|
|
421
|
|
|
422 -- Case of OR
|
|
|
423
|
|
|
424 when Tok_Or =>
|
|
|
425
|
|
|
426 -- Terminate if Ortm set or if the or is to the left of the
|
|
|
427 -- expected column of the end for this sequence.
|
|
|
428
|
|
|
429 if SS_Flags.Ortm
|
|
|
430 or else Start_Column < Scope.Table (Scope.Last).Ecol
|
|
|
431 then
|
|
|
432 Test_Statement_Required;
|
|
|
433 exit;
|
|
|
434
|
|
|
435 -- Otherwise complain and skip past or
|
|
|
436
|
|
|
437 else
|
|
|
438 Error_Msg_SC ("OR not allowed here");
|
|
|
439 Scan; -- past or
|
|
|
440 Statement_Required := False;
|
|
|
441 end if;
|
|
|
442
|
|
|
443 -- Case of THEN (deal also with THEN ABORT)
|
|
|
444
|
|
|
445 when Tok_Then =>
|
|
|
446 Save_Scan_State (Scan_State); -- at THEN
|
|
|
447 Scan; -- past THEN
|
|
|
448
|
|
|
449 -- Terminate if THEN ABORT allowed (ATC case)
|
|
|
450
|
|
|
451 exit when SS_Flags.Tatm and then Token = Tok_Abort;
|
|
|
452
|
|
|
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.
|
|
|
456
|
|
|
457 Restore_Scan_State (Scan_State); -- to THEN
|
|
|
458 Append_To (Statement_List, P_If_Statement);
|
|
|
459 Statement_Required := False;
|
|
|
460
|
|
|
461 -- Case of WHEN (error because we are not in a case)
|
|
|
462
|
|
|
463 when Tok_Others
|
|
|
464 | Tok_When
|
|
|
465 =>
|
|
|
466 -- Terminate if Whtm set or if the WHEN is to the left of
|
|
|
467 -- the expected column of the end for this sequence.
|
|
|
468
|
|
|
469 if SS_Flags.Whtm
|
|
|
470 or else Start_Column < Scope.Table (Scope.Last).Ecol
|
|
|
471 then
|
|
|
472 Test_Statement_Required;
|
|
|
473 exit;
|
|
|
474
|
|
|
475 -- Otherwise complain and skip when Choice {| Choice} =>
|
|
|
476
|
|
|
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;
|
|
|
484
|
|
|
485 -- Cases of statements starting with an identifier
|
|
|
486
|
|
|
487 when Tok_Identifier =>
|
|
|
488 Check_Bad_Layout;
|
|
|
489
|
|
|
490 -- Save scan pointers and line number in case block label
|
|
|
491
|
|
|
492 Id_Node := Token_Node;
|
|
|
493 Block_Label := Token_Name;
|
|
|
494 Save_Scan_State (Scan_State_Label); -- at possible label
|
|
|
495 Scan; -- past Id
|
|
|
496
|
|
|
497 -- Check for common case of assignment, since it occurs
|
|
|
498 -- frequently, and we want to process it efficiently.
|
|
|
499
|
|
|
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;
|
|
|
505
|
|
|
506 -- Check common case of procedure call, another case that
|
|
|
507 -- we want to speed up as much as possible.
|
|
|
508
|
|
|
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;
|
|
|
514
|
|
|
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.
|
|
|
520
|
|
|
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;
|
|
|
532
|
|
|
533 -- Check for case of "go to" in place of "goto"
|
|
|
534
|
|
|
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;
|
|
|
543
|
|
|
544 -- Check common case of = used instead of :=, just so we
|
|
|
545 -- give a better error message for this special misuse.
|
|
|
546
|
|
|
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;
|
|
|
552
|
|
|
553 -- Check case of loop label or block label
|
|
|
554
|
|
|
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)
|
|
|
560
|
|
|
561 -- Test for more than one label
|
|
|
562
|
|
|
563 loop
|
|
|
564 exit when Token /= Tok_Identifier;
|
|
|
565 Save_Scan_State (Scan_State); -- at second Id
|
|
|
566 Scan; -- past Id
|
|
|
567
|
|
|
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
|
|
|
572
|
|
|
573 -- Use the second label as the "real" label
|
|
|
574
|
|
|
575 Scan_State_Label := Scan_State;
|
|
|
576
|
|
|
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.
|
|
|
580
|
|
|
581 Block_Label := Error_Name;
|
|
|
582
|
|
|
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.
|
|
|
586
|
|
|
587 else
|
|
|
588 Restore_Scan_State (Scan_State); -- to second Id
|
|
|
589 exit;
|
|
|
590 end if;
|
|
|
591 end loop;
|
|
|
592
|
|
|
593 -- Loop_Statement (labeled Loop_Statement)
|
|
|
594
|
|
|
595 if Token = Tok_Loop then
|
|
|
596 Append_To (Statement_List,
|
|
|
597 P_Loop_Statement (Id_Node));
|
|
|
598
|
|
|
599 -- While statement (labeled loop statement with WHILE)
|
|
|
600
|
|
|
601 elsif Token = Tok_While then
|
|
|
602 Append_To (Statement_List,
|
|
|
603 P_While_Statement (Id_Node));
|
|
|
604
|
|
|
605 -- Declare statement (labeled block statement with
|
|
|
606 -- DECLARE part)
|
|
|
607
|
|
|
608 elsif Token = Tok_Declare then
|
|
|
609 Append_To (Statement_List,
|
|
|
610 P_Declare_Statement (Id_Node));
|
|
|
611
|
|
|
612 -- Begin statement (labeled block statement with no
|
|
|
613 -- DECLARE part)
|
|
|
614
|
|
|
615 elsif Token = Tok_Begin then
|
|
|
616 Append_To (Statement_List,
|
|
|
617 P_Begin_Statement (Id_Node));
|
|
|
618
|
|
|
619 -- For statement (labeled loop statement with FOR)
|
|
|
620
|
|
|
621 elsif Token = Tok_For then
|
|
|
622 Append_To (Statement_List,
|
|
|
623 P_For_Statement (Id_Node));
|
|
|
624
|
|
|
625 -- Improper statement follows label. If we have an
|
|
|
626 -- expression token, then assume the colon was part
|
|
|
627 -- of a misplaced declaration.
|
|
|
628
|
|
|
629 elsif Token not in Token_Class_Eterm then
|
|
|
630 Restore_Scan_State (Scan_State_Label);
|
|
|
631 Junk_Declaration;
|
|
|
632
|
|
|
633 -- Otherwise complain we have inappropriate statement
|
|
|
634
|
|
|
635 else
|
|
|
636 Error_Msg_AP
|
|
|
637 ("loop or block statement must follow label");
|
|
|
638 end if;
|
|
|
639
|
|
|
640 Statement_Required := False;
|
|
|
641
|
|
|
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
|
|
|
645
|
|
|
646 elsif Token in Token_Class_Namext then
|
|
|
647 Restore_Scan_State (Scan_State_Label); -- to Id
|
|
|
648 Name_Node := P_Name;
|
|
|
649
|
|
|
650 -- Skip junk right parens in this context
|
|
|
651
|
|
|
652 Ignore (Tok_Right_Paren);
|
|
|
653
|
|
|
654 -- Check context following call
|
|
|
655
|
|
|
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;
|
|
|
661
|
|
|
662 -- Check common case of = used instead of :=
|
|
|
663
|
|
|
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;
|
|
|
669
|
|
|
670 -- Check apostrophe cases
|
|
|
671
|
|
|
672 elsif Token = Tok_Apostrophe then
|
|
|
673 Append_To (Statement_List,
|
|
|
674 P_Code_Statement (Name_Node));
|
|
|
675 Statement_Required := False;
|
|
|
676
|
|
|
677 -- The only other valid item after a name is ; which
|
|
|
678 -- means that the item we just scanned was a call.
|
|
|
679
|
|
|
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;
|
|
|
685
|
|
|
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).
|
|
|
689
|
|
|
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;
|
|
|
699
|
|
|
700 -- Else we have a missing semicolon
|
|
|
701
|
|
|
702 else
|
|
|
703 TF_Semicolon;
|
|
|
704
|
|
|
705 -- Normal processing as though semicolon were present
|
|
|
706
|
|
|
707 Change_Name_To_Procedure_Call_Statement (Name_Node);
|
|
|
708 Append_To (Statement_List, Name_Node);
|
|
|
709 Statement_Required := False;
|
|
|
710 end if;
|
|
|
711
|
|
|
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.
|
|
|
721
|
|
|
722 else
|
|
|
723 Restore_Scan_State (Scan_State_Label); -- to identifier
|
|
|
724
|
|
|
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;
|
|
|
749
|
|
|
750 -- If not a bad spelling, then we really have junk
|
|
|
751
|
|
|
752 else
|
|
|
753 Scan; -- past identifier again
|
|
|
754
|
|
|
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.
|
|
|
759
|
|
|
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;
|
|
|
765
|
|
|
766 -- Otherwise we give a missing := message and
|
|
|
767 -- simply abandon the junk that is there now.
|
|
|
768
|
|
|
769 else
|
|
|
770 T_Colon_Equal; -- give := expected message
|
|
|
771 raise Error_Resync;
|
|
|
772 end if;
|
|
|
773
|
|
|
774 end if;
|
|
|
775 end if;
|
|
|
776
|
|
|
777 -- Statement starting with operator symbol. This could be
|
|
|
778 -- a call, a name starting an assignment, or a qualified
|
|
|
779 -- expression.
|
|
|
780
|
|
|
781 when Tok_Operator_Symbol =>
|
|
|
782 Check_Bad_Layout;
|
|
|
783 Name_Node := P_Name;
|
|
|
784
|
|
|
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).
|
|
|
788
|
|
|
789 if Token = Tok_Apostrophe then
|
|
|
790 Error_Msg_SC ("apostrophe illegal here");
|
|
|
791 raise Error_Resync;
|
|
|
792 end if;
|
|
|
793
|
|
|
794 -- Scan possible assignment if we have a name
|
|
|
795
|
|
|
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;
|
|
|
806
|
|
|
807 TF_Semicolon;
|
|
|
808 Statement_Required := False;
|
|
|
809
|
|
|
810 -- Label starting with << which must precede real statement
|
|
|
811 -- Note: in Ada 2012, the label may end the sequence.
|
|
|
812
|
|
|
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;
|
|
|
819
|
|
|
820 Append_To (Statement_List, P_Label);
|
|
|
821 Statement_Required := True;
|
|
|
822
|
|
|
823 -- Pragma appearing as a statement in a statement sequence
|
|
|
824
|
|
|
825 when Tok_Pragma =>
|
|
|
826 Check_Bad_Layout;
|
|
|
827 Append_To (Statement_List, P_Pragma);
|
|
|
828
|
|
|
829 -- Abort_Statement
|
|
|
830
|
|
|
831 when Tok_Abort =>
|
|
|
832 Check_Bad_Layout;
|
|
|
833 Append_To (Statement_List, P_Abort_Statement);
|
|
|
834 Statement_Required := False;
|
|
|
835
|
|
|
836 -- Accept_Statement
|
|
|
837
|
|
|
838 when Tok_Accept =>
|
|
|
839 Check_Bad_Layout;
|
|
|
840 Append_To (Statement_List, P_Accept_Statement);
|
|
|
841 Statement_Required := False;
|
|
|
842
|
|
|
843 -- Begin_Statement (Block_Statement with no declare, no label)
|
|
|
844
|
|
|
845 when Tok_Begin =>
|
|
|
846 Check_Bad_Layout;
|
|
|
847 Append_To (Statement_List, P_Begin_Statement);
|
|
|
848 Statement_Required := False;
|
|
|
849
|
|
|
850 -- Case_Statement
|
|
|
851
|
|
|
852 when Tok_Case =>
|
|
|
853 Check_Bad_Layout;
|
|
|
854 Append_To (Statement_List, P_Case_Statement);
|
|
|
855 Statement_Required := False;
|
|
|
856
|
|
|
857 -- Block_Statement with DECLARE and no label
|
|
|
858
|
|
|
859 when Tok_Declare =>
|
|
|
860 Check_Bad_Layout;
|
|
|
861 Append_To (Statement_List, P_Declare_Statement);
|
|
|
862 Statement_Required := False;
|
|
|
863
|
|
|
864 -- Delay_Statement
|
|
|
865
|
|
|
866 when Tok_Delay =>
|
|
|
867 Check_Bad_Layout;
|
|
|
868 Append_To (Statement_List, P_Delay_Statement);
|
|
|
869 Statement_Required := False;
|
|
|
870
|
|
|
871 -- Exit_Statement
|
|
|
872
|
|
|
873 when Tok_Exit =>
|
|
|
874 Check_Bad_Layout;
|
|
|
875 Append_To (Statement_List, P_Exit_Statement);
|
|
|
876 Statement_Required := False;
|
|
|
877
|
|
|
878 -- Loop_Statement with FOR and no label
|
|
|
879
|
|
|
880 when Tok_For =>
|
|
|
881 Check_Bad_Layout;
|
|
|
882 Append_To (Statement_List, P_For_Statement);
|
|
|
883 Statement_Required := False;
|
|
|
884
|
|
|
885 -- Goto_Statement
|
|
|
886
|
|
|
887 when Tok_Goto =>
|
|
|
888 Check_Bad_Layout;
|
|
|
889 Append_To (Statement_List, P_Goto_Statement);
|
|
|
890 Statement_Required := False;
|
|
|
891
|
|
|
892 -- If_Statement
|
|
|
893
|
|
|
894 when Tok_If =>
|
|
|
895 Check_Bad_Layout;
|
|
|
896 Append_To (Statement_List, P_If_Statement);
|
|
|
897 Statement_Required := False;
|
|
|
898
|
|
|
899 -- Loop_Statement
|
|
|
900
|
|
|
901 when Tok_Loop =>
|
|
|
902 Check_Bad_Layout;
|
|
|
903 Append_To (Statement_List, P_Loop_Statement);
|
|
|
904 Statement_Required := False;
|
|
|
905
|
|
|
906 -- Null_Statement
|
|
|
907
|
|
|
908 when Tok_Null =>
|
|
|
909 Check_Bad_Layout;
|
|
|
910 Append_To (Statement_List, P_Null_Statement);
|
|
|
911 Statement_Required := False;
|
|
|
912
|
|
|
913 -- Raise_Statement
|
|
|
914
|
|
|
915 when Tok_Raise =>
|
|
|
916 Check_Bad_Layout;
|
|
|
917 Append_To (Statement_List, P_Raise_Statement);
|
|
|
918 Statement_Required := False;
|
|
|
919
|
|
|
920 -- Requeue_Statement
|
|
|
921
|
|
|
922 when Tok_Requeue =>
|
|
|
923 Check_Bad_Layout;
|
|
|
924 Append_To (Statement_List, P_Requeue_Statement);
|
|
|
925 Statement_Required := False;
|
|
|
926
|
|
|
927 -- Return_Statement
|
|
|
928
|
|
|
929 when Tok_Return =>
|
|
|
930 Check_Bad_Layout;
|
|
|
931 Append_To (Statement_List, P_Return_Statement);
|
|
|
932 Statement_Required := False;
|
|
|
933
|
|
|
934 -- Select_Statement
|
|
|
935
|
|
|
936 when Tok_Select =>
|
|
|
937 Check_Bad_Layout;
|
|
|
938 Append_To (Statement_List, P_Select_Statement);
|
|
|
939 Statement_Required := False;
|
|
|
940
|
|
|
941 -- While_Statement (Block_Statement with while and no loop)
|
|
|
942
|
|
|
943 when Tok_While =>
|
|
|
944 Check_Bad_Layout;
|
|
|
945 Append_To (Statement_List, P_While_Statement);
|
|
|
946 Statement_Required := False;
|
|
|
947
|
|
|
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.
|
|
|
951
|
|
|
952 when others =>
|
|
|
953 if Token in Token_Class_Declk then
|
|
|
954 Junk_Declaration;
|
|
|
955
|
|
|
956 else
|
|
|
957 Error_Msg_BC -- CODEFIX
|
|
|
958 ("statement expected");
|
|
|
959 raise Error_Resync;
|
|
|
960 end if;
|
|
|
961 end case;
|
|
|
962
|
|
|
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).
|
|
|
968
|
|
|
969 exception
|
|
|
970 when Error_Resync =>
|
|
|
971 Resync_Past_Semicolon_Or_To_Loop_Or_Then;
|
|
|
972 Statement_Required := False;
|
|
|
973 end;
|
|
|
974
|
|
|
975 exit when SS_Flags.Unco;
|
|
|
976 end loop;
|
|
|
977
|
|
|
978 return Statement_List;
|
|
|
979 end P_Sequence_Of_Statements;
|
|
|
980
|
|
|
981 --------------------
|
|
|
982 -- 5.1 Statement --
|
|
|
983 --------------------
|
|
|
984
|
|
|
985 ---------------------------
|
|
|
986 -- 5.1 Simple Statement --
|
|
|
987 ---------------------------
|
|
|
988
|
|
|
989 -- Parsed by P_Sequence_Of_Statements (5.1)
|
|
|
990
|
|
|
991 -----------------------------
|
|
|
992 -- 5.1 Compound Statement --
|
|
|
993 -----------------------------
|
|
|
994
|
|
|
995 -- Parsed by P_Sequence_Of_Statements (5.1)
|
|
|
996
|
|
|
997 -------------------------
|
|
|
998 -- 5.1 Null Statement --
|
|
|
999 -------------------------
|
|
|
1000
|
|
|
1001 -- NULL_STATEMENT ::= null;
|
|
|
1002
|
|
|
1003 -- The caller has already checked that the current token is null
|
|
|
1004
|
|
|
1005 -- Error recovery: cannot raise Error_Resync
|
|
|
1006
|
|
|
1007 function P_Null_Statement return Node_Id is
|
|
|
1008 Null_Stmt_Node : Node_Id;
|
|
|
1009
|
|
|
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;
|
|
|
1016
|
|
|
1017 ----------------
|
|
|
1018 -- 5.1 Label --
|
|
|
1019 ----------------
|
|
|
1020
|
|
|
1021 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
|
|
|
1022
|
|
|
1023 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
|
|
|
1024
|
|
|
1025 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
|
|
|
1026 -- (not an OPERATOR_SYMBOL)
|
|
|
1027
|
|
|
1028 -- The caller has already checked that the current token is <<
|
|
|
1029
|
|
|
1030 -- Error recovery: can raise Error_Resync
|
|
|
1031
|
|
|
1032 function P_Label return Node_Id is
|
|
|
1033 Label_Node : Node_Id;
|
|
|
1034
|
|
|
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;
|
|
|
1043
|
|
|
1044 -------------------------------
|
|
|
1045 -- 5.1 Statement Identifier --
|
|
|
1046 -------------------------------
|
|
|
1047
|
|
|
1048 -- Statement label is parsed by P_Label (5.1)
|
|
|
1049
|
|
|
1050 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
|
|
|
1051 -- or P_While_Statement (5.5)
|
|
|
1052
|
|
|
1053 -- Block label is parsed by P_Begin_Statement (5.6) or
|
|
|
1054 -- P_Declare_Statement (5.6)
|
|
|
1055
|
|
|
1056 -------------------------------
|
|
|
1057 -- 5.2 Assignment Statement --
|
|
|
1058 -------------------------------
|
|
|
1059
|
|
|
1060 -- ASSIGNMENT_STATEMENT ::=
|
|
|
1061 -- variable_NAME := EXPRESSION;
|
|
|
1062
|
|
|
1063 -- Error recovery: can raise Error_Resync
|
|
|
1064
|
|
|
1065 function P_Assignment_Statement (LHS : Node_Id) return Node_Id is
|
|
|
1066 Assign_Node : Node_Id;
|
|
|
1067
|
|
|
1068 begin
|
|
|
1069 Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr);
|
|
|
1070 Current_Assign_Node := Assign_Node;
|
|
|
1071 Set_Name (Assign_Node, LHS);
|
|
|
1072 Set_Expression (Assign_Node, P_Expression_No_Right_Paren);
|
|
|
1073 TF_Semicolon;
|
|
|
1074 Current_Assign_Node := Empty;
|
|
|
1075 return Assign_Node;
|
|
|
1076 end P_Assignment_Statement;
|
|
|
1077
|
|
|
1078 -----------------------
|
|
|
1079 -- 5.3 If Statement --
|
|
|
1080 -----------------------
|
|
|
1081
|
|
|
1082 -- IF_STATEMENT ::=
|
|
|
1083 -- if CONDITION then
|
|
|
1084 -- SEQUENCE_OF_STATEMENTS
|
|
|
1085 -- {elsif CONDITION then
|
|
|
1086 -- SEQUENCE_OF_STATEMENTS}
|
|
|
1087 -- [else
|
|
|
1088 -- SEQUENCE_OF_STATEMENTS]
|
|
|
1089 -- end if;
|
|
|
1090
|
|
|
1091 -- The caller has checked that the initial token is IF (or in the error
|
|
|
1092 -- case of a mysterious THEN, the initial token may simply be THEN, in
|
|
|
1093 -- which case, no condition (or IF) was scanned).
|
|
|
1094
|
|
|
1095 -- Error recovery: can raise Error_Resync
|
|
|
1096
|
|
|
1097 function P_If_Statement return Node_Id is
|
|
|
1098 If_Node : Node_Id;
|
|
|
1099 Elsif_Node : Node_Id;
|
|
|
1100 Loc : Source_Ptr;
|
|
|
1101
|
|
|
1102 procedure Add_Elsif_Part;
|
|
|
1103 -- An internal procedure used to scan out a single ELSIF part. On entry
|
|
|
1104 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is
|
|
|
1105 -- scanned out and is in Prev_Token.
|
|
|
1106
|
|
|
1107 procedure Check_If_Column;
|
|
|
1108 -- An internal procedure used to check that THEN, ELSE, or ELSIF
|
|
|
1109 -- appear in the right place if column checking is enabled (i.e. if
|
|
|
1110 -- they are the first token on the line, then they must appear in
|
|
|
1111 -- the same column as the opening IF).
|
|
|
1112
|
|
|
1113 procedure Check_Then_Column;
|
|
|
1114 -- This procedure carries out the style checks for a THEN token
|
|
|
1115 -- Note that the caller has set Loc to the Source_Ptr value for
|
|
|
1116 -- the previous IF or ELSIF token.
|
|
|
1117
|
|
|
1118 function Else_Should_Be_Elsif return Boolean;
|
|
|
1119 -- An internal routine used to do a special error recovery check when
|
|
|
1120 -- an ELSE is encountered. It determines if the ELSE should be treated
|
|
|
1121 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
|
|
|
1122 -- is followed by a sequence of tokens, starting on the same line as
|
|
|
1123 -- the ELSE, which are not expression terminators, followed by a THEN.
|
|
|
1124 -- On entry, the ELSE has been scanned out.
|
|
|
1125
|
|
|
1126 procedure Add_Elsif_Part is
|
|
|
1127 begin
|
|
|
1128 if No (Elsif_Parts (If_Node)) then
|
|
|
1129 Set_Elsif_Parts (If_Node, New_List);
|
|
|
1130 end if;
|
|
|
1131
|
|
|
1132 Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr);
|
|
|
1133 Loc := Prev_Token_Ptr;
|
|
|
1134 Set_Condition (Elsif_Node, P_Condition);
|
|
|
1135 Check_Then_Column;
|
|
|
1136 Then_Scan;
|
|
|
1137 Set_Then_Statements
|
|
|
1138 (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
|
|
|
1139 Append (Elsif_Node, Elsif_Parts (If_Node));
|
|
|
1140 end Add_Elsif_Part;
|
|
|
1141
|
|
|
1142 procedure Check_If_Column is
|
|
|
1143 begin
|
|
|
1144 if RM_Column_Check and then Token_Is_At_Start_Of_Line
|
|
|
1145 and then Start_Column /= Scope.Table (Scope.Last).Ecol
|
|
|
1146 then
|
|
|
1147 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
|
|
|
1148 Error_Msg_SC ("(style) this token should be@");
|
|
|
1149 end if;
|
|
|
1150 end Check_If_Column;
|
|
|
1151
|
|
|
1152 procedure Check_Then_Column is
|
|
|
1153 begin
|
|
|
1154 if Token = Tok_Then then
|
|
|
1155 Check_If_Column;
|
|
|
1156
|
|
|
1157 if Style_Check then
|
|
|
1158 Style.Check_Then (Loc);
|
|
|
1159 end if;
|
|
|
1160 end if;
|
|
|
1161 end Check_Then_Column;
|
|
|
1162
|
|
|
1163 function Else_Should_Be_Elsif return Boolean is
|
|
|
1164 Scan_State : Saved_Scan_State;
|
|
|
1165
|
|
|
1166 begin
|
|
|
1167 if Token_Is_At_Start_Of_Line then
|
|
|
1168 return False;
|
|
|
1169
|
|
|
1170 else
|
|
|
1171 Save_Scan_State (Scan_State);
|
|
|
1172
|
|
|
1173 loop
|
|
|
1174 if Token in Token_Class_Eterm then
|
|
|
1175 Restore_Scan_State (Scan_State);
|
|
|
1176 return False;
|
|
|
1177 else
|
|
|
1178 Scan; -- past non-expression terminating token
|
|
|
1179
|
|
|
1180 if Token = Tok_Then then
|
|
|
1181 Restore_Scan_State (Scan_State);
|
|
|
1182 return True;
|
|
|
1183 end if;
|
|
|
1184 end if;
|
|
|
1185 end loop;
|
|
|
1186 end if;
|
|
|
1187 end Else_Should_Be_Elsif;
|
|
|
1188
|
|
|
1189 -- Start of processing for P_If_Statement
|
|
|
1190
|
|
|
1191 begin
|
|
|
1192 If_Node := New_Node (N_If_Statement, Token_Ptr);
|
|
|
1193
|
|
|
1194 Push_Scope_Stack;
|
|
|
1195 Scope.Table (Scope.Last).Etyp := E_If;
|
|
|
1196 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
1197 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
1198 Scope.Table (Scope.Last).Labl := Error;
|
|
|
1199 Scope.Table (Scope.Last).Node := If_Node;
|
|
|
1200
|
|
|
1201 if Token = Tok_If then
|
|
|
1202 Loc := Token_Ptr;
|
|
|
1203 Scan; -- past IF
|
|
|
1204 Set_Condition (If_Node, P_Condition);
|
|
|
1205
|
|
|
1206 -- Deal with misuse of IF expression => used instead
|
|
|
1207 -- of WHEN expression =>
|
|
|
1208
|
|
|
1209 if Token = Tok_Arrow then
|
|
|
1210 Error_Msg_SC -- CODEFIX
|
|
|
1211 ("THEN expected");
|
|
|
1212 Scan; -- past the arrow
|
|
|
1213 Pop_Scope_Stack; -- remove unneeded entry
|
|
|
1214 raise Error_Resync;
|
|
|
1215 end if;
|
|
|
1216
|
|
|
1217 Check_Then_Column;
|
|
|
1218
|
|
|
1219 else
|
|
|
1220 Error_Msg_SC ("no IF for this THEN");
|
|
|
1221 Set_Condition (If_Node, Error);
|
|
|
1222 end if;
|
|
|
1223
|
|
|
1224 Then_Scan;
|
|
|
1225
|
|
|
1226 Set_Then_Statements
|
|
|
1227 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
|
|
|
1228
|
|
|
1229 -- This loop scans out else and elsif parts
|
|
|
1230
|
|
|
1231 loop
|
|
|
1232 if Token = Tok_Elsif then
|
|
|
1233 Check_If_Column;
|
|
|
1234
|
|
|
1235 if Present (Else_Statements (If_Node)) then
|
|
|
1236 Error_Msg_SP ("ELSIF cannot appear after ELSE");
|
|
|
1237 end if;
|
|
|
1238
|
|
|
1239 Scan; -- past ELSIF
|
|
|
1240 Add_Elsif_Part;
|
|
|
1241
|
|
|
1242 elsif Token = Tok_Else then
|
|
|
1243 Check_If_Column;
|
|
|
1244 Scan; -- past ELSE
|
|
|
1245
|
|
|
1246 if Else_Should_Be_Elsif then
|
|
|
1247 Error_Msg_SP -- CODEFIX
|
|
|
1248 ("ELSE should be ELSIF");
|
|
|
1249 Add_Elsif_Part;
|
|
|
1250
|
|
|
1251 else
|
|
|
1252 -- Here we have an else that really is an else
|
|
|
1253
|
|
|
1254 if Present (Else_Statements (If_Node)) then
|
|
|
1255 Error_Msg_SP ("only one ELSE part allowed");
|
|
|
1256 Append_List
|
|
|
1257 (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
|
|
|
1258 Else_Statements (If_Node));
|
|
|
1259 else
|
|
|
1260 Set_Else_Statements
|
|
|
1261 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
|
|
|
1262 end if;
|
|
|
1263 end if;
|
|
|
1264
|
|
|
1265 -- If anything other than ELSE or ELSIF, exit the loop. The token
|
|
|
1266 -- had better be END (and in fact it had better be END IF), but
|
|
|
1267 -- we will let End_Statements take care of checking that.
|
|
|
1268
|
|
|
1269 else
|
|
|
1270 exit;
|
|
|
1271 end if;
|
|
|
1272 end loop;
|
|
|
1273
|
|
|
1274 End_Statements;
|
|
|
1275 return If_Node;
|
|
|
1276
|
|
|
1277 end P_If_Statement;
|
|
|
1278
|
|
|
1279 --------------------
|
|
|
1280 -- 5.3 Condition --
|
|
|
1281 --------------------
|
|
|
1282
|
|
|
1283 -- CONDITION ::= boolean_EXPRESSION
|
|
|
1284
|
|
|
1285 function P_Condition return Node_Id is
|
|
|
1286 begin
|
|
|
1287 return P_Condition (P_Expression_No_Right_Paren);
|
|
|
1288 end P_Condition;
|
|
|
1289
|
|
|
1290 function P_Condition (Cond : Node_Id) return Node_Id is
|
|
|
1291 begin
|
|
|
1292 -- It is never possible for := to follow a condition, so if we get
|
|
|
1293 -- a := we assume it is a mistyped equality. Note that we do not try
|
|
|
1294 -- to reconstruct the tree correctly in this case, but we do at least
|
|
|
1295 -- give an accurate error message.
|
|
|
1296
|
|
|
1297 if Token = Tok_Colon_Equal then
|
|
|
1298 while Token = Tok_Colon_Equal loop
|
|
|
1299 Error_Msg_SC -- CODEFIX
|
|
|
1300 (""":="" should be ""=""");
|
|
|
1301 Scan; -- past junk :=
|
|
|
1302 Discard_Junk_Node (P_Expression_No_Right_Paren);
|
|
|
1303 end loop;
|
|
|
1304
|
|
|
1305 return Cond;
|
|
|
1306
|
|
|
1307 -- Otherwise check for redundant parentheses
|
|
|
1308
|
|
|
1309 -- If the condition is a conditional or a quantified expression, it is
|
|
|
1310 -- parenthesized in the context of a condition, because of a separate
|
|
|
1311 -- syntax rule.
|
|
|
1312
|
|
|
1313 else
|
|
|
1314 if Style_Check and then Paren_Count (Cond) > 0 then
|
|
|
1315 if not Nkind_In (Cond, N_If_Expression,
|
|
|
1316 N_Case_Expression,
|
|
|
1317 N_Quantified_Expression)
|
|
|
1318 or else Paren_Count (Cond) > 1
|
|
|
1319 then
|
|
|
1320 Style.Check_Xtra_Parens (First_Sloc (Cond));
|
|
|
1321 end if;
|
|
|
1322 end if;
|
|
|
1323
|
|
|
1324 -- And return the result
|
|
|
1325
|
|
|
1326 return Cond;
|
|
|
1327 end if;
|
|
|
1328 end P_Condition;
|
|
|
1329
|
|
|
1330 -------------------------
|
|
|
1331 -- 5.4 Case Statement --
|
|
|
1332 -------------------------
|
|
|
1333
|
|
|
1334 -- CASE_STATEMENT ::=
|
|
|
1335 -- case EXPRESSION is
|
|
|
1336 -- CASE_STATEMENT_ALTERNATIVE
|
|
|
1337 -- {CASE_STATEMENT_ALTERNATIVE}
|
|
|
1338 -- end case;
|
|
|
1339
|
|
|
1340 -- The caller has checked that the first token is CASE
|
|
|
1341
|
|
|
1342 -- Can raise Error_Resync
|
|
|
1343
|
|
|
1344 function P_Case_Statement return Node_Id is
|
|
|
1345 Case_Node : Node_Id;
|
|
|
1346 Alternatives_List : List_Id;
|
|
|
1347 First_When_Loc : Source_Ptr;
|
|
|
1348
|
|
|
1349 begin
|
|
|
1350 Case_Node := New_Node (N_Case_Statement, Token_Ptr);
|
|
|
1351
|
|
|
1352 Push_Scope_Stack;
|
|
|
1353 Scope.Table (Scope.Last).Etyp := E_Case;
|
|
|
1354 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
1355 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
1356 Scope.Table (Scope.Last).Labl := Error;
|
|
|
1357 Scope.Table (Scope.Last).Node := Case_Node;
|
|
|
1358
|
|
|
1359 Scan; -- past CASE
|
|
|
1360 Set_Expression (Case_Node, P_Expression_No_Right_Paren);
|
|
|
1361 TF_Is;
|
|
|
1362
|
|
|
1363 -- Prepare to parse case statement alternatives
|
|
|
1364
|
|
|
1365 Alternatives_List := New_List;
|
|
|
1366 P_Pragmas_Opt (Alternatives_List);
|
|
|
1367 First_When_Loc := Token_Ptr;
|
|
|
1368
|
|
|
1369 -- Loop through case statement alternatives
|
|
|
1370
|
|
|
1371 loop
|
|
|
1372 -- If we have a WHEN or OTHERS, then that's fine keep going. Note
|
|
|
1373 -- that it is a semantic check to ensure the proper use of OTHERS
|
|
|
1374
|
|
|
1375 if Token = Tok_When or else Token = Tok_Others then
|
|
|
1376 Append (P_Case_Statement_Alternative, Alternatives_List);
|
|
|
1377
|
|
|
1378 -- If we have an END, then probably we are at the end of the case
|
|
|
1379 -- but we only exit if Check_End thinks the END was reasonable.
|
|
|
1380
|
|
|
1381 elsif Token = Tok_End then
|
|
|
1382 exit when Check_End;
|
|
|
1383
|
|
|
1384 -- Here if token is other than WHEN, OTHERS or END. We definitely
|
|
|
1385 -- have an error, but the question is whether or not to get out of
|
|
|
1386 -- the case statement. We don't want to get out early, or we will
|
|
|
1387 -- get a slew of junk error messages for subsequent when tokens.
|
|
|
1388
|
|
|
1389 -- If the token is not at the start of the line, or if it is indented
|
|
|
1390 -- with respect to the current case statement, then the best guess is
|
|
|
1391 -- that we are still supposed to be inside the case statement. We
|
|
|
1392 -- complain about the missing WHEN, and discard the junk statements.
|
|
|
1393
|
|
|
1394 elsif not Token_Is_At_Start_Of_Line
|
|
|
1395 or else Start_Column > Scope.Table (Scope.Last).Ecol
|
|
|
1396 then
|
|
|
1397 Error_Msg_BC ("WHEN (case statement alternative) expected");
|
|
|
1398
|
|
|
1399 -- Here is a possibility for infinite looping if we don't make
|
|
|
1400 -- progress. So try to process statements, otherwise exit
|
|
|
1401
|
|
|
1402 declare
|
|
|
1403 Error_Ptr : constant Source_Ptr := Scan_Ptr;
|
|
|
1404 begin
|
|
|
1405 Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm));
|
|
|
1406 exit when Scan_Ptr = Error_Ptr and then Check_End;
|
|
|
1407 end;
|
|
|
1408
|
|
|
1409 -- Here we have a junk token at the start of the line and it is
|
|
|
1410 -- not indented. If Check_End thinks there is a missing END, then
|
|
|
1411 -- we will get out of the case, otherwise we keep going.
|
|
|
1412
|
|
|
1413 else
|
|
|
1414 exit when Check_End;
|
|
|
1415 end if;
|
|
|
1416 end loop;
|
|
|
1417
|
|
|
1418 -- Make sure we have at least one alternative
|
|
|
1419
|
|
|
1420 if No (First_Non_Pragma (Alternatives_List)) then
|
|
|
1421 Error_Msg
|
|
|
1422 ("WHEN expected, must have at least one alternative in case",
|
|
|
1423 First_When_Loc);
|
|
|
1424 return Error;
|
|
|
1425
|
|
|
1426 else
|
|
|
1427 Set_Alternatives (Case_Node, Alternatives_List);
|
|
|
1428 return Case_Node;
|
|
|
1429 end if;
|
|
|
1430 end P_Case_Statement;
|
|
|
1431
|
|
|
1432 -------------------------------------
|
|
|
1433 -- 5.4 Case Statement Alternative --
|
|
|
1434 -------------------------------------
|
|
|
1435
|
|
|
1436 -- CASE_STATEMENT_ALTERNATIVE ::=
|
|
|
1437 -- when DISCRETE_CHOICE_LIST =>
|
|
|
1438 -- SEQUENCE_OF_STATEMENTS
|
|
|
1439
|
|
|
1440 -- The caller has checked that the initial token is WHEN or OTHERS
|
|
|
1441 -- Error recovery: can raise Error_Resync
|
|
|
1442
|
|
|
1443 function P_Case_Statement_Alternative return Node_Id is
|
|
|
1444 Case_Alt_Node : Node_Id;
|
|
|
1445
|
|
|
1446 begin
|
|
|
1447 if Style_Check then
|
|
|
1448 Style.Check_Indentation;
|
|
|
1449 end if;
|
|
|
1450
|
|
|
1451 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
|
|
|
1452 T_When; -- past WHEN (or give error in OTHERS case)
|
|
|
1453 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
|
|
|
1454 TF_Arrow;
|
|
|
1455 Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
|
|
|
1456 return Case_Alt_Node;
|
|
|
1457 end P_Case_Statement_Alternative;
|
|
|
1458
|
|
|
1459 -------------------------
|
|
|
1460 -- 5.5 Loop Statement --
|
|
|
1461 -------------------------
|
|
|
1462
|
|
|
1463 -- LOOP_STATEMENT ::=
|
|
|
1464 -- [LOOP_STATEMENT_IDENTIFIER:]
|
|
|
1465 -- [ITERATION_SCHEME] loop
|
|
|
1466 -- SEQUENCE_OF_STATEMENTS
|
|
|
1467 -- end loop [loop_IDENTIFIER];
|
|
|
1468
|
|
|
1469 -- ITERATION_SCHEME ::=
|
|
|
1470 -- while CONDITION
|
|
|
1471 -- | for LOOP_PARAMETER_SPECIFICATION
|
|
|
1472
|
|
|
1473 -- The parsing of loop statements is handled by one of three functions
|
|
|
1474 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending
|
|
|
1475 -- on the initial keyword in the construct (excluding the identifier)
|
|
|
1476
|
|
|
1477 -- P_Loop_Statement
|
|
|
1478
|
|
|
1479 -- This function parses the case where no iteration scheme is present
|
|
|
1480
|
|
|
1481 -- The caller has checked that the initial token is LOOP. The parameter
|
|
|
1482 -- is the node identifiers for the loop label if any (or is set to Empty
|
|
|
1483 -- if there is no loop label).
|
|
|
1484
|
|
|
1485 -- Error recovery : cannot raise Error_Resync
|
|
|
1486
|
|
|
1487 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
|
|
|
1488 Loop_Node : Node_Id;
|
|
|
1489 Created_Name : Node_Id;
|
|
|
1490
|
|
|
1491 begin
|
|
|
1492 Push_Scope_Stack;
|
|
|
1493 Scope.Table (Scope.Last).Labl := Loop_Name;
|
|
|
1494 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
1495 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
1496 Scope.Table (Scope.Last).Etyp := E_Loop;
|
|
|
1497
|
|
|
1498 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
|
|
|
1499 TF_Loop;
|
|
|
1500
|
|
|
1501 if No (Loop_Name) then
|
|
|
1502 Created_Name :=
|
|
|
1503 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
|
|
|
1504 Set_Comes_From_Source (Created_Name, False);
|
|
|
1505 Set_Has_Created_Identifier (Loop_Node, True);
|
|
|
1506 Set_Identifier (Loop_Node, Created_Name);
|
|
|
1507 Scope.Table (Scope.Last).Labl := Created_Name;
|
|
|
1508 else
|
|
|
1509 Set_Identifier (Loop_Node, Loop_Name);
|
|
|
1510 end if;
|
|
|
1511
|
|
|
1512 Append_Elmt (Loop_Node, Label_List);
|
|
|
1513 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
|
|
|
1514 End_Statements (Loop_Node);
|
|
|
1515 return Loop_Node;
|
|
|
1516 end P_Loop_Statement;
|
|
|
1517
|
|
|
1518 -- P_For_Statement
|
|
|
1519
|
|
|
1520 -- This function parses a loop statement with a FOR iteration scheme
|
|
|
1521
|
|
|
1522 -- The caller has checked that the initial token is FOR. The parameter
|
|
|
1523 -- is the node identifier for the block label if any (or is set to Empty
|
|
|
1524 -- if there is no block label).
|
|
|
1525
|
|
|
1526 -- Note: the caller fills in the Identifier field if a label was present
|
|
|
1527
|
|
|
1528 -- Error recovery: can raise Error_Resync
|
|
|
1529
|
|
|
1530 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
|
|
|
1531 Loop_Node : Node_Id;
|
|
|
1532 Iter_Scheme_Node : Node_Id;
|
|
|
1533 Loop_For_Flag : Boolean;
|
|
|
1534 Created_Name : Node_Id;
|
|
|
1535 Spec : Node_Id;
|
|
|
1536
|
|
|
1537 begin
|
|
|
1538 Push_Scope_Stack;
|
|
|
1539 Scope.Table (Scope.Last).Labl := Loop_Name;
|
|
|
1540 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
1541 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
1542 Scope.Table (Scope.Last).Etyp := E_Loop;
|
|
|
1543
|
|
|
1544 Loop_For_Flag := (Prev_Token = Tok_Loop);
|
|
|
1545 Scan; -- past FOR
|
|
|
1546 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
|
|
|
1547 Spec := P_Loop_Parameter_Specification;
|
|
|
1548
|
|
|
1549 if Nkind (Spec) = N_Loop_Parameter_Specification then
|
|
|
1550 Set_Loop_Parameter_Specification (Iter_Scheme_Node, Spec);
|
|
|
1551 else
|
|
|
1552 Set_Iterator_Specification (Iter_Scheme_Node, Spec);
|
|
|
1553 end if;
|
|
|
1554
|
|
|
1555 -- The following is a special test so that a miswritten for loop such
|
|
|
1556 -- as "loop for I in 1..10;" is handled nicely, without making an extra
|
|
|
1557 -- entry in the scope stack. We don't bother to actually fix up the
|
|
|
1558 -- tree in this case since it's not worth the effort. Instead we just
|
|
|
1559 -- eat up the loop junk, leaving the entry for what now looks like an
|
|
|
1560 -- unmodified loop intact.
|
|
|
1561
|
|
|
1562 if Loop_For_Flag and then Token = Tok_Semicolon then
|
|
|
1563 Error_Msg_SC ("LOOP belongs here, not before FOR");
|
|
|
1564 Pop_Scope_Stack;
|
|
|
1565 return Error;
|
|
|
1566
|
|
|
1567 -- Normal case
|
|
|
1568
|
|
|
1569 else
|
|
|
1570 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
|
|
|
1571
|
|
|
1572 if No (Loop_Name) then
|
|
|
1573 Created_Name :=
|
|
|
1574 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
|
|
|
1575 Set_Comes_From_Source (Created_Name, False);
|
|
|
1576 Set_Has_Created_Identifier (Loop_Node, True);
|
|
|
1577 Set_Identifier (Loop_Node, Created_Name);
|
|
|
1578 Scope.Table (Scope.Last).Labl := Created_Name;
|
|
|
1579 else
|
|
|
1580 Set_Identifier (Loop_Node, Loop_Name);
|
|
|
1581 end if;
|
|
|
1582
|
|
|
1583 TF_Loop;
|
|
|
1584 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
|
|
|
1585 End_Statements (Loop_Node);
|
|
|
1586 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
|
|
|
1587 Append_Elmt (Loop_Node, Label_List);
|
|
|
1588 return Loop_Node;
|
|
|
1589 end if;
|
|
|
1590 end P_For_Statement;
|
|
|
1591
|
|
|
1592 -- P_While_Statement
|
|
|
1593
|
|
|
1594 -- This procedure scans a loop statement with a WHILE iteration scheme
|
|
|
1595
|
|
|
1596 -- The caller has checked that the initial token is WHILE. The parameter
|
|
|
1597 -- is the node identifier for the block label if any (or is set to Empty
|
|
|
1598 -- if there is no block label).
|
|
|
1599
|
|
|
1600 -- Error recovery: cannot raise Error_Resync
|
|
|
1601
|
|
|
1602 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
|
|
|
1603 Loop_Node : Node_Id;
|
|
|
1604 Iter_Scheme_Node : Node_Id;
|
|
|
1605 Loop_While_Flag : Boolean;
|
|
|
1606 Created_Name : Node_Id;
|
|
|
1607
|
|
|
1608 begin
|
|
|
1609 Push_Scope_Stack;
|
|
|
1610 Scope.Table (Scope.Last).Labl := Loop_Name;
|
|
|
1611 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
1612 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
1613 Scope.Table (Scope.Last).Etyp := E_Loop;
|
|
|
1614
|
|
|
1615 Loop_While_Flag := (Prev_Token = Tok_Loop);
|
|
|
1616 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
|
|
|
1617 Scan; -- past WHILE
|
|
|
1618 Set_Condition (Iter_Scheme_Node, P_Condition);
|
|
|
1619
|
|
|
1620 -- The following is a special test so that a miswritten for loop such
|
|
|
1621 -- as "loop while I > 10;" is handled nicely, without making an extra
|
|
|
1622 -- entry in the scope stack. We don't bother to actually fix up the
|
|
|
1623 -- tree in this case since it's not worth the effort. Instead we just
|
|
|
1624 -- eat up the loop junk, leaving the entry for what now looks like an
|
|
|
1625 -- unmodified loop intact.
|
|
|
1626
|
|
|
1627 if Loop_While_Flag and then Token = Tok_Semicolon then
|
|
|
1628 Error_Msg_SC ("LOOP belongs here, not before WHILE");
|
|
|
1629 Pop_Scope_Stack;
|
|
|
1630 return Error;
|
|
|
1631
|
|
|
1632 -- Normal case
|
|
|
1633
|
|
|
1634 else
|
|
|
1635 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
|
|
|
1636 TF_Loop;
|
|
|
1637
|
|
|
1638 if No (Loop_Name) then
|
|
|
1639 Created_Name :=
|
|
|
1640 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'));
|
|
|
1641 Set_Comes_From_Source (Created_Name, False);
|
|
|
1642 Set_Has_Created_Identifier (Loop_Node, True);
|
|
|
1643 Set_Identifier (Loop_Node, Created_Name);
|
|
|
1644 Scope.Table (Scope.Last).Labl := Created_Name;
|
|
|
1645 else
|
|
|
1646 Set_Identifier (Loop_Node, Loop_Name);
|
|
|
1647 end if;
|
|
|
1648
|
|
|
1649 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
|
|
|
1650 End_Statements (Loop_Node);
|
|
|
1651 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
|
|
|
1652 Append_Elmt (Loop_Node, Label_List);
|
|
|
1653 return Loop_Node;
|
|
|
1654 end if;
|
|
|
1655 end P_While_Statement;
|
|
|
1656
|
|
|
1657 ---------------------------------------
|
|
|
1658 -- 5.5 Loop Parameter Specification --
|
|
|
1659 ---------------------------------------
|
|
|
1660
|
|
|
1661 -- LOOP_PARAMETER_SPECIFICATION ::=
|
|
|
1662 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
|
|
|
1663
|
|
|
1664 -- Error recovery: cannot raise Error_Resync
|
|
|
1665
|
|
|
1666 function P_Loop_Parameter_Specification return Node_Id is
|
|
|
1667 Loop_Param_Specification_Node : Node_Id;
|
|
|
1668
|
|
|
1669 ID_Node : Node_Id;
|
|
|
1670 Scan_State : Saved_Scan_State;
|
|
|
1671
|
|
|
1672 begin
|
|
|
1673
|
|
|
1674 Save_Scan_State (Scan_State);
|
|
|
1675 ID_Node := P_Defining_Identifier (C_In);
|
|
|
1676
|
|
|
1677 -- If the next token is OF, it indicates an Ada 2012 iterator. If the
|
|
|
1678 -- next token is a colon, this is also an Ada 2012 iterator, including
|
|
|
1679 -- a subtype indication for the loop parameter. Otherwise we parse the
|
|
|
1680 -- construct as a loop parameter specification. Note that the form
|
|
|
1681 -- "for A in B" is ambiguous, and must be resolved semantically: if B
|
|
|
1682 -- is a discrete subtype this is a loop specification, but if it is an
|
|
|
1683 -- expression it is an iterator specification. Ambiguity is resolved
|
|
|
1684 -- during analysis of the loop parameter specification.
|
|
|
1685
|
|
|
1686 if Token = Tok_Of or else Token = Tok_Colon then
|
|
|
1687 Error_Msg_Ada_2012_Feature ("iterator", Token_Ptr);
|
|
|
1688 return P_Iterator_Specification (ID_Node);
|
|
|
1689 end if;
|
|
|
1690
|
|
|
1691 -- The span of the Loop_Parameter_Specification starts at the
|
|
|
1692 -- defining identifier.
|
|
|
1693
|
|
|
1694 Loop_Param_Specification_Node :=
|
|
|
1695 New_Node (N_Loop_Parameter_Specification, Sloc (ID_Node));
|
|
|
1696 Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
|
|
|
1697
|
|
|
1698 if Token = Tok_Left_Paren then
|
|
|
1699 Error_Msg_SC ("subscripted loop parameter not allowed");
|
|
|
1700 Restore_Scan_State (Scan_State);
|
|
|
1701 Discard_Junk_Node (P_Name);
|
|
|
1702
|
|
|
1703 elsif Token = Tok_Dot then
|
|
|
1704 Error_Msg_SC ("selected loop parameter not allowed");
|
|
|
1705 Restore_Scan_State (Scan_State);
|
|
|
1706 Discard_Junk_Node (P_Name);
|
|
|
1707 end if;
|
|
|
1708
|
|
|
1709 T_In;
|
|
|
1710
|
|
|
1711 if Token = Tok_Reverse then
|
|
|
1712 Scan; -- past REVERSE
|
|
|
1713 Set_Reverse_Present (Loop_Param_Specification_Node, True);
|
|
|
1714 end if;
|
|
|
1715
|
|
|
1716 Set_Discrete_Subtype_Definition
|
|
|
1717 (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
|
|
|
1718 return Loop_Param_Specification_Node;
|
|
|
1719
|
|
|
1720 exception
|
|
|
1721 when Error_Resync =>
|
|
|
1722 return Error;
|
|
|
1723 end P_Loop_Parameter_Specification;
|
|
|
1724
|
|
|
1725 ----------------------------------
|
|
|
1726 -- 5.5.1 Iterator_Specification --
|
|
|
1727 ----------------------------------
|
|
|
1728
|
|
|
1729 function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id is
|
|
|
1730 Node1 : Node_Id;
|
|
|
1731
|
|
|
1732 begin
|
|
|
1733 Node1 := New_Node (N_Iterator_Specification, Sloc (Def_Id));
|
|
|
1734 Set_Defining_Identifier (Node1, Def_Id);
|
|
|
1735
|
|
|
1736 if Token = Tok_Colon then
|
|
|
1737 Scan; -- past :
|
|
|
1738 Set_Subtype_Indication (Node1, P_Subtype_Indication);
|
|
|
1739 end if;
|
|
|
1740
|
|
|
1741 if Token = Tok_Of then
|
|
|
1742 Set_Of_Present (Node1);
|
|
|
1743 Scan; -- past OF
|
|
|
1744
|
|
|
1745 elsif Token = Tok_In then
|
|
|
1746 Scan; -- past IN
|
|
|
1747
|
|
|
1748 elsif Prev_Token = Tok_In
|
|
|
1749 and then Present (Subtype_Indication (Node1))
|
|
|
1750 then
|
|
|
1751 -- Simplest recovery is to transform it into an element iterator.
|
|
|
1752 -- Error message on 'in" has already been emitted when parsing the
|
|
|
1753 -- optional constraint.
|
|
|
1754
|
|
|
1755 Set_Of_Present (Node1);
|
|
|
1756 Error_Msg_N
|
|
|
1757 ("subtype indication is only legal on an element iterator",
|
|
|
1758 Subtype_Indication (Node1));
|
|
|
1759
|
|
|
1760 else
|
|
|
1761 return Error;
|
|
|
1762 end if;
|
|
|
1763
|
|
|
1764 if Token = Tok_Reverse then
|
|
|
1765 Scan; -- past REVERSE
|
|
|
1766 Set_Reverse_Present (Node1, True);
|
|
|
1767 end if;
|
|
|
1768
|
|
|
1769 Set_Name (Node1, P_Name);
|
|
|
1770 return Node1;
|
|
|
1771 end P_Iterator_Specification;
|
|
|
1772
|
|
|
1773 --------------------------
|
|
|
1774 -- 5.6 Block Statement --
|
|
|
1775 --------------------------
|
|
|
1776
|
|
|
1777 -- BLOCK_STATEMENT ::=
|
|
|
1778 -- [block_STATEMENT_IDENTIFIER:]
|
|
|
1779 -- [declare
|
|
|
1780 -- DECLARATIVE_PART]
|
|
|
1781 -- begin
|
|
|
1782 -- HANDLED_SEQUENCE_OF_STATEMENTS
|
|
|
1783 -- end [block_IDENTIFIER];
|
|
|
1784
|
|
|
1785 -- The parsing of block statements is handled by one of the two functions
|
|
|
1786 -- P_Declare_Statement or P_Begin_Statement depending on whether or not
|
|
|
1787 -- a declare section is present
|
|
|
1788
|
|
|
1789 -- P_Declare_Statement
|
|
|
1790
|
|
|
1791 -- This function parses a block statement with DECLARE present
|
|
|
1792
|
|
|
1793 -- The caller has checked that the initial token is DECLARE
|
|
|
1794
|
|
|
1795 -- Error recovery: cannot raise Error_Resync
|
|
|
1796
|
|
|
1797 function P_Declare_Statement
|
|
|
1798 (Block_Name : Node_Id := Empty)
|
|
|
1799 return Node_Id
|
|
|
1800 is
|
|
|
1801 Block_Node : Node_Id;
|
|
|
1802 Created_Name : Node_Id;
|
|
|
1803
|
|
|
1804 begin
|
|
|
1805 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
|
|
|
1806
|
|
|
1807 Push_Scope_Stack;
|
|
|
1808 Scope.Table (Scope.Last).Etyp := E_Name;
|
|
|
1809 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
|
|
|
1810 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
1811 Scope.Table (Scope.Last).Labl := Block_Name;
|
|
|
1812 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
1813
|
|
|
1814 Scan; -- past DECLARE
|
|
|
1815
|
|
|
1816 if No (Block_Name) then
|
|
|
1817 Created_Name :=
|
|
|
1818 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
|
|
|
1819 Set_Comes_From_Source (Created_Name, False);
|
|
|
1820 Set_Has_Created_Identifier (Block_Node, True);
|
|
|
1821 Set_Identifier (Block_Node, Created_Name);
|
|
|
1822 Scope.Table (Scope.Last).Labl := Created_Name;
|
|
|
1823 else
|
|
|
1824 Set_Identifier (Block_Node, Block_Name);
|
|
|
1825 end if;
|
|
|
1826
|
|
|
1827 Append_Elmt (Block_Node, Label_List);
|
|
|
1828 Parse_Decls_Begin_End (Block_Node);
|
|
|
1829 return Block_Node;
|
|
|
1830 end P_Declare_Statement;
|
|
|
1831
|
|
|
1832 -- P_Begin_Statement
|
|
|
1833
|
|
|
1834 -- This function parses a block statement with no DECLARE present
|
|
|
1835
|
|
|
1836 -- The caller has checked that the initial token is BEGIN
|
|
|
1837
|
|
|
1838 -- Error recovery: cannot raise Error_Resync
|
|
|
1839
|
|
|
1840 function P_Begin_Statement
|
|
|
1841 (Block_Name : Node_Id := Empty)
|
|
|
1842 return Node_Id
|
|
|
1843 is
|
|
|
1844 Block_Node : Node_Id;
|
|
|
1845 Created_Name : Node_Id;
|
|
|
1846
|
|
|
1847 begin
|
|
|
1848 Block_Node := New_Node (N_Block_Statement, Token_Ptr);
|
|
|
1849
|
|
|
1850 Push_Scope_Stack;
|
|
|
1851 Scope.Table (Scope.Last).Etyp := E_Name;
|
|
|
1852 Scope.Table (Scope.Last).Lreq := Present (Block_Name);
|
|
|
1853 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
1854 Scope.Table (Scope.Last).Labl := Block_Name;
|
|
|
1855 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
1856
|
|
|
1857 if No (Block_Name) then
|
|
|
1858 Created_Name :=
|
|
|
1859 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'));
|
|
|
1860 Set_Comes_From_Source (Created_Name, False);
|
|
|
1861 Set_Has_Created_Identifier (Block_Node, True);
|
|
|
1862 Set_Identifier (Block_Node, Created_Name);
|
|
|
1863 Scope.Table (Scope.Last).Labl := Created_Name;
|
|
|
1864 else
|
|
|
1865 Set_Identifier (Block_Node, Block_Name);
|
|
|
1866 end if;
|
|
|
1867
|
|
|
1868 Append_Elmt (Block_Node, Label_List);
|
|
|
1869
|
|
|
1870 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
1871 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
1872 Scan; -- past BEGIN
|
|
|
1873 Set_Handled_Statement_Sequence
|
|
|
1874 (Block_Node, P_Handled_Sequence_Of_Statements);
|
|
|
1875 End_Statements (Handled_Statement_Sequence (Block_Node));
|
|
|
1876 return Block_Node;
|
|
|
1877 end P_Begin_Statement;
|
|
|
1878
|
|
|
1879 -------------------------
|
|
|
1880 -- 5.7 Exit Statement --
|
|
|
1881 -------------------------
|
|
|
1882
|
|
|
1883 -- EXIT_STATEMENT ::=
|
|
|
1884 -- exit [loop_NAME] [when CONDITION];
|
|
|
1885
|
|
|
1886 -- The caller has checked that the initial token is EXIT
|
|
|
1887
|
|
|
1888 -- Error recovery: can raise Error_Resync
|
|
|
1889
|
|
|
1890 function P_Exit_Statement return Node_Id is
|
|
|
1891 Exit_Node : Node_Id;
|
|
|
1892
|
|
|
1893 function Missing_Semicolon_On_Exit return Boolean;
|
|
|
1894 -- This function deals with the following specialized situation
|
|
|
1895 --
|
|
|
1896 -- when 'x' =>
|
|
|
1897 -- exit [identifier]
|
|
|
1898 -- when 'y' =>
|
|
|
1899 --
|
|
|
1900 -- This looks like a messed up EXIT WHEN, when in fact the problem
|
|
|
1901 -- is a missing semicolon. It is called with Token pointing to the
|
|
|
1902 -- WHEN token, and returns True if a semicolon is missing before
|
|
|
1903 -- the WHEN as in the above example.
|
|
|
1904
|
|
|
1905 -------------------------------
|
|
|
1906 -- Missing_Semicolon_On_Exit --
|
|
|
1907 -------------------------------
|
|
|
1908
|
|
|
1909 function Missing_Semicolon_On_Exit return Boolean is
|
|
|
1910 State : Saved_Scan_State;
|
|
|
1911
|
|
|
1912 begin
|
|
|
1913 if not Token_Is_At_Start_Of_Line then
|
|
|
1914 return False;
|
|
|
1915
|
|
|
1916 elsif Scope.Table (Scope.Last).Etyp /= E_Case then
|
|
|
1917 return False;
|
|
|
1918
|
|
|
1919 else
|
|
|
1920 Save_Scan_State (State);
|
|
|
1921 Scan; -- past WHEN
|
|
|
1922 Scan; -- past token after WHEN
|
|
|
1923
|
|
|
1924 if Token = Tok_Arrow then
|
|
|
1925 Restore_Scan_State (State);
|
|
|
1926 return True;
|
|
|
1927 else
|
|
|
1928 Restore_Scan_State (State);
|
|
|
1929 return False;
|
|
|
1930 end if;
|
|
|
1931 end if;
|
|
|
1932 end Missing_Semicolon_On_Exit;
|
|
|
1933
|
|
|
1934 -- Start of processing for P_Exit_Statement
|
|
|
1935
|
|
|
1936 begin
|
|
|
1937 Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
|
|
|
1938 Scan; -- past EXIT
|
|
|
1939
|
|
|
1940 if Token = Tok_Identifier then
|
|
|
1941 Set_Name (Exit_Node, P_Qualified_Simple_Name);
|
|
|
1942
|
|
|
1943 elsif Style_Check then
|
|
|
1944 -- This EXIT has no name, so check that
|
|
|
1945 -- the innermost loop is unnamed too.
|
|
|
1946
|
|
|
1947 Check_No_Exit_Name :
|
|
|
1948 for J in reverse 1 .. Scope.Last loop
|
|
|
1949 if Scope.Table (J).Etyp = E_Loop then
|
|
|
1950 if Present (Scope.Table (J).Labl)
|
|
|
1951 and then Comes_From_Source (Scope.Table (J).Labl)
|
|
|
1952 then
|
|
|
1953 -- Innermost loop in fact had a name, style check fails
|
|
|
1954
|
|
|
1955 Style.No_Exit_Name (Scope.Table (J).Labl);
|
|
|
1956 end if;
|
|
|
1957
|
|
|
1958 exit Check_No_Exit_Name;
|
|
|
1959 end if;
|
|
|
1960 end loop Check_No_Exit_Name;
|
|
|
1961 end if;
|
|
|
1962
|
|
|
1963 if Token = Tok_When and then not Missing_Semicolon_On_Exit then
|
|
|
1964 Scan; -- past WHEN
|
|
|
1965 Set_Condition (Exit_Node, P_Condition);
|
|
|
1966
|
|
|
1967 -- Allow IF instead of WHEN, giving error message
|
|
|
1968
|
|
|
1969 elsif Token = Tok_If then
|
|
|
1970 T_When;
|
|
|
1971 Scan; -- past IF used in place of WHEN
|
|
|
1972 Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
|
|
|
1973 end if;
|
|
|
1974
|
|
|
1975 TF_Semicolon;
|
|
|
1976 return Exit_Node;
|
|
|
1977 end P_Exit_Statement;
|
|
|
1978
|
|
|
1979 -------------------------
|
|
|
1980 -- 5.8 Goto Statement --
|
|
|
1981 -------------------------
|
|
|
1982
|
|
|
1983 -- GOTO_STATEMENT ::= goto label_NAME;
|
|
|
1984
|
|
|
1985 -- The caller has checked that the initial token is GOTO (or TO in the
|
|
|
1986 -- error case where GO and TO were incorrectly separated).
|
|
|
1987
|
|
|
1988 -- Error recovery: can raise Error_Resync
|
|
|
1989
|
|
|
1990 function P_Goto_Statement return Node_Id is
|
|
|
1991 Goto_Node : Node_Id;
|
|
|
1992
|
|
|
1993 begin
|
|
|
1994 Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
|
|
|
1995 Scan; -- past GOTO (or TO)
|
|
|
1996 Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
|
|
|
1997 Append_Elmt (Goto_Node, Goto_List);
|
|
|
1998 No_Constraint;
|
|
|
1999 TF_Semicolon;
|
|
|
2000 return Goto_Node;
|
|
|
2001 end P_Goto_Statement;
|
|
|
2002
|
|
|
2003 ---------------------------
|
|
|
2004 -- Parse_Decls_Begin_End --
|
|
|
2005 ---------------------------
|
|
|
2006
|
|
|
2007 -- This function parses the construct:
|
|
|
2008
|
|
|
2009 -- DECLARATIVE_PART
|
|
|
2010 -- begin
|
|
|
2011 -- HANDLED_SEQUENCE_OF_STATEMENTS
|
|
|
2012 -- end [NAME];
|
|
|
2013
|
|
|
2014 -- The caller has built the scope stack entry, and created the node to
|
|
|
2015 -- whose Declarations and Handled_Statement_Sequence fields are to be
|
|
|
2016 -- set. On return these fields are filled in (except in the case of a
|
|
|
2017 -- task body, where the handled statement sequence is optional, and may
|
|
|
2018 -- thus be Empty), and the scan is positioned past the End sequence.
|
|
|
2019
|
|
|
2020 -- If the BEGIN is missing, then the parent node is used to help construct
|
|
|
2021 -- an appropriate missing BEGIN message. Possibilities for the parent are:
|
|
|
2022
|
|
|
2023 -- N_Block_Statement declare block
|
|
|
2024 -- N_Entry_Body entry body
|
|
|
2025 -- N_Package_Body package body (begin part optional)
|
|
|
2026 -- N_Subprogram_Body procedure or function body
|
|
|
2027 -- N_Task_Body task body
|
|
|
2028
|
|
|
2029 -- Note: in the case of a block statement, there is definitely a DECLARE
|
|
|
2030 -- present (because a Begin statement without a DECLARE is handled by the
|
|
|
2031 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
|
|
|
2032
|
|
|
2033 -- Error recovery: cannot raise Error_Resync
|
|
|
2034
|
|
|
2035 procedure Parse_Decls_Begin_End (Parent : Node_Id) is
|
|
|
2036 Body_Decl : Node_Id;
|
|
|
2037 Decls : List_Id;
|
|
|
2038 Parent_Nkind : Node_Kind;
|
|
|
2039 Spec_Node : Node_Id;
|
|
|
2040 HSS : Node_Id;
|
|
|
2041
|
|
|
2042 procedure Missing_Begin (Msg : String);
|
|
|
2043 -- Called to post a missing begin message. In the normal case this is
|
|
|
2044 -- posted at the start of the current token. A special case arises when
|
|
|
2045 -- P_Declarative_Items has previously found a missing begin, in which
|
|
|
2046 -- case we replace the original error message.
|
|
|
2047
|
|
|
2048 procedure Set_Null_HSS (Parent : Node_Id);
|
|
|
2049 -- Construct an empty handled statement sequence and install in Parent
|
|
|
2050 -- Leaves HSS set to reference the newly constructed statement sequence.
|
|
|
2051
|
|
|
2052 -------------------
|
|
|
2053 -- Missing_Begin --
|
|
|
2054 -------------------
|
|
|
2055
|
|
|
2056 procedure Missing_Begin (Msg : String) is
|
|
|
2057 begin
|
|
|
2058 if Missing_Begin_Msg = No_Error_Msg then
|
|
|
2059 Error_Msg_BC (Msg);
|
|
|
2060 else
|
|
|
2061 Change_Error_Text (Missing_Begin_Msg, Msg);
|
|
|
2062
|
|
|
2063 -- Purge any messages issued after than, since a missing begin
|
|
|
2064 -- can cause a lot of havoc, and it is better not to dump these
|
|
|
2065 -- cascaded messages on the user.
|
|
|
2066
|
|
|
2067 Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
|
|
|
2068 end if;
|
|
|
2069 end Missing_Begin;
|
|
|
2070
|
|
|
2071 ------------------
|
|
|
2072 -- Set_Null_HSS --
|
|
|
2073 ------------------
|
|
|
2074
|
|
|
2075 procedure Set_Null_HSS (Parent : Node_Id) is
|
|
|
2076 Null_Stm : Node_Id;
|
|
|
2077
|
|
|
2078 begin
|
|
|
2079 Null_Stm :=
|
|
|
2080 Make_Null_Statement (Token_Ptr);
|
|
|
2081 Set_Comes_From_Source (Null_Stm, False);
|
|
|
2082
|
|
|
2083 HSS :=
|
|
|
2084 Make_Handled_Sequence_Of_Statements (Token_Ptr,
|
|
|
2085 Statements => New_List (Null_Stm));
|
|
|
2086 Set_Comes_From_Source (HSS, False);
|
|
|
2087
|
|
|
2088 Set_Handled_Statement_Sequence (Parent, HSS);
|
|
|
2089 end Set_Null_HSS;
|
|
|
2090
|
|
|
2091 -- Start of processing for Parse_Decls_Begin_End
|
|
|
2092
|
|
|
2093 begin
|
|
|
2094 Decls := P_Declarative_Part;
|
|
|
2095
|
|
|
2096 if Ada_Version = Ada_83 then
|
|
|
2097 Check_Later_Vs_Basic_Declarations (Decls, During_Parsing => True);
|
|
|
2098 end if;
|
|
|
2099
|
|
|
2100 -- Here is where we deal with the case of IS used instead of semicolon.
|
|
|
2101 -- Specifically, if the last declaration in the declarative part is a
|
|
|
2102 -- subprogram body still marked as having a bad IS, then this is where
|
|
|
2103 -- we decide that the IS should really have been a semicolon and that
|
|
|
2104 -- the body should have been a declaration. Note that if the bad IS
|
|
|
2105 -- had turned out to be OK (i.e. a decent begin/end was found for it),
|
|
|
2106 -- then the Bad_Is_Detected flag would have been reset by now.
|
|
|
2107
|
|
|
2108 Body_Decl := Last (Decls);
|
|
|
2109
|
|
|
2110 if Present (Body_Decl)
|
|
|
2111 and then Nkind (Body_Decl) = N_Subprogram_Body
|
|
|
2112 and then Bad_Is_Detected (Body_Decl)
|
|
|
2113 then
|
|
|
2114 -- OK, we have the case of a bad IS, so we need to fix up the tree.
|
|
|
2115 -- What we have now is a subprogram body with attached declarations
|
|
|
2116 -- and a possible statement sequence.
|
|
|
2117
|
|
|
2118 -- First step is to take the declarations that were part of the bogus
|
|
|
2119 -- subprogram body and append them to the outer declaration chain.
|
|
|
2120 -- In other words we append them past the body (which we will later
|
|
|
2121 -- convert into a declaration).
|
|
|
2122
|
|
|
2123 Append_List (Declarations (Body_Decl), Decls);
|
|
|
2124
|
|
|
2125 -- Now take the handled statement sequence of the bogus body and
|
|
|
2126 -- set it as the statement sequence for the outer construct. Note
|
|
|
2127 -- that it may be empty (we specially allowed a missing BEGIN for
|
|
|
2128 -- a subprogram body marked as having a bad IS -- see below).
|
|
|
2129
|
|
|
2130 Set_Handled_Statement_Sequence (Parent,
|
|
|
2131 Handled_Statement_Sequence (Body_Decl));
|
|
|
2132
|
|
|
2133 -- Next step is to convert the old body node to a declaration node
|
|
|
2134
|
|
|
2135 Spec_Node := Specification (Body_Decl);
|
|
|
2136 Change_Node (Body_Decl, N_Subprogram_Declaration);
|
|
|
2137 Set_Specification (Body_Decl, Spec_Node);
|
|
|
2138
|
|
|
2139 -- Final step is to put the declarations for the parent where
|
|
|
2140 -- they belong, and then fall through the IF to scan out the
|
|
|
2141 -- END statements.
|
|
|
2142
|
|
|
2143 Set_Declarations (Parent, Decls);
|
|
|
2144
|
|
|
2145 -- This is the normal case (i.e. any case except the bad IS case)
|
|
|
2146 -- If we have a BEGIN, then scan out the sequence of statements, and
|
|
|
2147 -- also reset the expected column for the END to match the BEGIN.
|
|
|
2148
|
|
|
2149 else
|
|
|
2150 Set_Declarations (Parent, Decls);
|
|
|
2151
|
|
|
2152 if Token = Tok_Begin then
|
|
|
2153 if Style_Check then
|
|
|
2154 Style.Check_Indentation;
|
|
|
2155 end if;
|
|
|
2156
|
|
|
2157 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
|
|
|
2158
|
|
|
2159 if RM_Column_Check
|
|
|
2160 and then Token_Is_At_Start_Of_Line
|
|
|
2161 and then Start_Column /= Error_Msg_Col
|
|
|
2162 then
|
|
|
2163 Error_Msg_SC ("(style) BEGIN in wrong column, should be@");
|
|
|
2164
|
|
|
2165 else
|
|
|
2166 Scope.Table (Scope.Last).Ecol := Start_Column;
|
|
|
2167 end if;
|
|
|
2168
|
|
|
2169 Scope.Table (Scope.Last).Sloc := Token_Ptr;
|
|
|
2170 Scan; -- past BEGIN
|
|
|
2171 Set_Handled_Statement_Sequence (Parent,
|
|
|
2172 P_Handled_Sequence_Of_Statements);
|
|
|
2173
|
|
|
2174 -- No BEGIN present
|
|
|
2175
|
|
|
2176 else
|
|
|
2177 Parent_Nkind := Nkind (Parent);
|
|
|
2178
|
|
|
2179 -- A special check for the missing IS case. If we have a
|
|
|
2180 -- subprogram body that was marked as having a suspicious
|
|
|
2181 -- IS, and the current token is END, then we simply confirm
|
|
|
2182 -- the suspicion, and do not require a BEGIN to be present
|
|
|
2183
|
|
|
2184 if Parent_Nkind = N_Subprogram_Body
|
|
|
2185 and then Token = Tok_End
|
|
|
2186 and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is
|
|
|
2187 then
|
|
|
2188 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
|
|
|
2189
|
|
|
2190 -- Otherwise BEGIN is not required for a package body, so we
|
|
|
2191 -- don't mind if it is missing, but we do construct a dummy
|
|
|
2192 -- one (so that we have somewhere to set End_Label).
|
|
|
2193
|
|
|
2194 -- However if we have something other than a BEGIN which
|
|
|
2195 -- looks like it might be statements, then we signal a missing
|
|
|
2196 -- BEGIN for these cases as well. We define "something which
|
|
|
2197 -- looks like it might be statements" as a token other than
|
|
|
2198 -- END, EOF, or a token which starts declarations.
|
|
|
2199
|
|
|
2200 elsif Parent_Nkind = N_Package_Body
|
|
|
2201 and then (Token = Tok_End
|
|
|
2202 or else Token = Tok_EOF
|
|
|
2203 or else Token in Token_Class_Declk)
|
|
|
2204 then
|
|
|
2205 Set_Null_HSS (Parent);
|
|
|
2206
|
|
|
2207 -- These are cases in which a BEGIN is required and not present
|
|
|
2208
|
|
|
2209 else
|
|
|
2210 Set_Null_HSS (Parent);
|
|
|
2211
|
|
|
2212 -- Prepare to issue error message
|
|
|
2213
|
|
|
2214 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
|
|
|
2215 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
|
|
|
2216
|
|
|
2217 -- Now issue appropriate message
|
|
|
2218
|
|
|
2219 if Parent_Nkind = N_Block_Statement then
|
|
|
2220 Missing_Begin ("missing BEGIN for DECLARE#!");
|
|
|
2221
|
|
|
2222 elsif Parent_Nkind = N_Entry_Body then
|
|
|
2223 Missing_Begin ("missing BEGIN for ENTRY#!");
|
|
|
2224
|
|
|
2225 elsif Parent_Nkind = N_Subprogram_Body then
|
|
|
2226 if Nkind (Specification (Parent))
|
|
|
2227 = N_Function_Specification
|
|
|
2228 then
|
|
|
2229 Missing_Begin ("missing BEGIN for function&#!");
|
|
|
2230 else
|
|
|
2231 Missing_Begin ("missing BEGIN for procedure&#!");
|
|
|
2232 end if;
|
|
|
2233
|
|
|
2234 -- The case for package body arises only when
|
|
|
2235 -- we have possible statement junk present.
|
|
|
2236
|
|
|
2237 elsif Parent_Nkind = N_Package_Body then
|
|
|
2238 Missing_Begin ("missing BEGIN for package body&#!");
|
|
|
2239
|
|
|
2240 else
|
|
|
2241 pragma Assert (Parent_Nkind = N_Task_Body);
|
|
|
2242 Missing_Begin ("missing BEGIN for task body&#!");
|
|
|
2243 end if;
|
|
|
2244
|
|
|
2245 -- Here we pick up the statements after the BEGIN that
|
|
|
2246 -- should have been present but was not. We don't insist
|
|
|
2247 -- on statements being present if P_Declarative_Part had
|
|
|
2248 -- already found a missing BEGIN, since it might have
|
|
|
2249 -- swallowed a lone statement into the declarative part.
|
|
|
2250
|
|
|
2251 if Missing_Begin_Msg /= No_Error_Msg
|
|
|
2252 and then Token = Tok_End
|
|
|
2253 then
|
|
|
2254 null;
|
|
|
2255 else
|
|
|
2256 Set_Handled_Statement_Sequence (Parent,
|
|
|
2257 P_Handled_Sequence_Of_Statements);
|
|
|
2258 end if;
|
|
|
2259 end if;
|
|
|
2260 end if;
|
|
|
2261 end if;
|
|
|
2262
|
|
|
2263 -- Here with declarations and handled statement sequence scanned
|
|
|
2264
|
|
|
2265 if Present (Handled_Statement_Sequence (Parent)) then
|
|
|
2266 End_Statements (Handled_Statement_Sequence (Parent));
|
|
|
2267 else
|
|
|
2268 End_Statements;
|
|
|
2269 end if;
|
|
|
2270
|
|
|
2271 -- We know that End_Statements removed an entry from the scope stack
|
|
|
2272 -- (because it is required to do so under all circumstances). We can
|
|
|
2273 -- therefore reference the entry it removed one past the stack top.
|
|
|
2274 -- What we are interested in is whether it was a case of a bad IS.
|
|
|
2275
|
|
|
2276 if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
|
|
|
2277 Error_Msg -- CODEFIX
|
|
|
2278 ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
|
|
|
2279 Set_Bad_Is_Detected (Parent, True);
|
|
|
2280 end if;
|
|
|
2281
|
|
|
2282 end Parse_Decls_Begin_End;
|
|
|
2283
|
|
|
2284 -------------------------
|
|
|
2285 -- Set_Loop_Block_Name --
|
|
|
2286 -------------------------
|
|
|
2287
|
|
|
2288 function Set_Loop_Block_Name (L : Character) return Name_Id is
|
|
|
2289 begin
|
|
|
2290 Name_Buffer (1) := L;
|
|
|
2291 Name_Buffer (2) := '_';
|
|
|
2292 Name_Len := 2;
|
|
|
2293 Loop_Block_Count := Loop_Block_Count + 1;
|
|
|
2294 Add_Nat_To_Name_Buffer (Loop_Block_Count);
|
|
|
2295 return Name_Find;
|
|
|
2296 end Set_Loop_Block_Name;
|
|
|
2297
|
|
|
2298 ---------------
|
|
|
2299 -- Then_Scan --
|
|
|
2300 ---------------
|
|
|
2301
|
|
|
2302 procedure Then_Scan is
|
|
|
2303 begin
|
|
|
2304 TF_Then;
|
|
|
2305
|
|
|
2306 while Token = Tok_Then loop
|
|
|
2307 Error_Msg_SC -- CODEFIX
|
|
|
2308 ("redundant THEN");
|
|
|
2309 TF_Then;
|
|
|
2310 end loop;
|
|
|
2311
|
|
|
2312 if Token = Tok_And or else Token = Tok_Or then
|
|
|
2313 Error_Msg_SC ("unexpected logical operator");
|
|
|
2314 Scan; -- past logical operator
|
|
|
2315
|
|
|
2316 if (Prev_Token = Tok_And and then Token = Tok_Then)
|
|
|
2317 or else
|
|
|
2318 (Prev_Token = Tok_Or and then Token = Tok_Else)
|
|
|
2319 then
|
|
|
2320 Scan;
|
|
|
2321 end if;
|
|
|
2322
|
|
|
2323 Discard_Junk_Node (P_Expression);
|
|
|
2324 end if;
|
|
|
2325
|
|
|
2326 if Token = Tok_Then then
|
|
|
2327 Scan;
|
|
|
2328 end if;
|
|
|
2329 end Then_Scan;
|
|
|
2330
|
|
|
2331 end Ch5;
|
