OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [par-ch5.adb] - Blame information for rev 320

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.