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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [par-endh.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             P A R . E N D H                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2011, 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
with Namet.Sp; use Namet.Sp;
27
with Stringt;  use Stringt;
28
with Uintp;    use Uintp;
29
 
30
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
31
 
32
separate (Par)
33
package body Endh is
34
 
35
   ----------------
36
   -- Local Data --
37
   ----------------
38
 
39
   type End_Action_Type is (
40
   --  Type used to describe the result of the Pop_End_Context call
41
 
42
      Accept_As_Scanned,
43
      --  Current end sequence is entirely c correct. In this case Token and
44
      --  the scan pointer are left pointing past the end sequence (i.e. they
45
      --  are unchanged from the values set on entry to Pop_End_Context).
46
 
47
      Insert_And_Accept,
48
      --  Current end sequence is to be left in place to satisfy some outer
49
      --  scope. Token and the scan pointer are set to point to the end
50
      --  token, and should be left there. A message has been generated
51
      --  indicating a missing end sequence. This status is also used for
52
      --  the case when no end token is present.
53
 
54
      Skip_And_Accept,
55
      --  The end sequence is incorrect (and an error message has been
56
      --  posted), but it will still be accepted. In this case Token and
57
      --  the scan pointer point back to the end token, and the caller
58
      --  should skip past the end sequence before proceeding.
59
 
60
      Skip_And_Reject);
61
      --  The end sequence is judged to belong to an unrecognized inner
62
      --  scope. An appropriate message has been issued and the caller
63
      --  should skip past the end sequence and then proceed as though
64
      --  no end sequence had been encountered.
65
 
66
   End_Action : End_Action_Type;
67
   --  The variable set by Pop_End_Context call showing which of the four
68
   --  decisions described above is judged the best.
69
 
70
   End_Sloc : Source_Ptr;
71
   --  Source location of END token
72
 
73
   End_OK : Boolean;
74
   --  Set False if error is found in END line
75
 
76
   End_Column : Column_Number;
77
   --  Column of END line
78
 
79
   End_Type : SS_End_Type;
80
   --  Type of END expected. The special value E_Dummy is set to indicate that
81
   --  no END token was present (so a missing END inserted message is needed)
82
 
83
   End_Labl : Node_Id;
84
   --  Node_Id value for explicit name on END line, or for compiler supplied
85
   --  name in the case where an optional name is not given. Empty if no name
86
   --  appears. If non-empty, then it is either an N_Designator node for a
87
   --  child unit or a node with a Chars field identifying the actual label.
88
 
89
   End_Labl_Present : Boolean;
90
   --  Indicates that the value in End_Labl was for an explicit label
91
 
92
   Syntax_OK : Boolean;
93
   --  Set True if the entry is syntactically correct
94
 
95
   Token_OK : Boolean;
96
   --  Set True if the keyword in the END sequence matches, or if neither
97
   --  the END sequence nor the END stack entry has a keyword.
98
 
99
   Label_OK : Boolean;
100
   --  Set True if both the END sequence and the END stack entry contained
101
   --  labels (other than No_Name or Error_Name) and the labels matched.
102
   --  This is a stronger condition than SYNTAX_OK, since it means that a
103
   --  label was present, even in a case where it was optional. Note that
104
   --  the case of no label required, and no label present does NOT set
105
   --  Label_OK to True, it is True only if a positive label match is found.
106
 
107
   Column_OK : Boolean;
108
   --  Column_OK is set True if the END sequence appears in the expected column
109
 
110
   Scan_State : Saved_Scan_State;
111
   --  Save state at start of END sequence, in case we decide not to eat it up
112
 
113
   -----------------------
114
   -- Local Subprograms --
115
   -----------------------
116
 
117
   procedure Evaluate_End_Entry (SS_Index : Nat);
118
   --  Compare scanned END entry (as recorded by a prior call to P_End_Scan)
119
   --  with a specified entry in the scope stack (the single parameter is the
120
   --  entry index in the scope stack). Note that Scan is not called. The above
121
   --  variables xxx_OK are set to indicate the result of the evaluation.
122
 
123
   function Explicit_Start_Label (SS_Index : Nat) return Boolean;
124
   --  Determines whether the specified entry in the scope stack has an
125
   --  explicit start label (i.e. one other than one that was created by
126
   --  the parser when no explicit label was present).
127
 
128
   procedure Output_End_Deleted;
129
   --  Output a message complaining that the current END structure does not
130
   --  match anything and is being deleted.
131
 
132
   procedure Output_End_Expected (Ins : Boolean);
133
   --  Output a message at the start of the current token which is always an
134
   --  END, complaining that the END is not of the right form. The message
135
   --  indicates the expected form. The information for the message is taken
136
   --  from the top entry in the scope stack. The Ins parameter is True if
137
   --  an end is being inserted, and false if an existing end is being
138
   --  replaced. Note that in the case of a suspicious IS for the Ins case,
139
   --  we do not output the message, but instead simply mark the scope stack
140
   --  entry as being a case of a bad IS.
141
 
142
   procedure Output_End_Missing;
143
   --  Output a message just before the current token, complaining that the
144
   --  END is not of the right form. The message indicates the expected form.
145
   --  The information for the message is taken from the top entry in the
146
   --  scope stack. Note that in the case of a suspicious IS, we do not output
147
   --  the message, but instead simply mark the scope stack entry as a bad IS.
148
 
149
   procedure Pop_End_Context;
150
   --  Pop_End_Context is called after processing a construct, to pop the
151
   --  top entry off the end stack. It decides on the appropriate action to
152
   --  to take, signalling the result by setting End_Action as described in
153
   --  the global variable section.
154
 
155
   function Same_Label (Label1, Label2 : Node_Id) return Boolean;
156
   --  This function compares the two names associated with the given nodes.
157
   --  If they are both simple (i.e. have Chars fields), then they have to
158
   --  be the same name. Otherwise they must both be N_Selected_Component
159
   --  nodes, referring to the same set of names, or Label1 is an N_Designator
160
   --  referring to the same set of names as the N_Defining_Program_Unit_Name
161
   --  in Label2. Any other combination returns False. This routine is used
162
   --  to compare the End_Labl scanned from the End line with the saved label
163
   --  value in the scope stack.
164
 
165
   ---------------
166
   -- Check_End --
167
   ---------------
168
 
169
   function Check_End
170
     (Decl   : Node_Id    := Empty;
171
      Is_Loc : Source_Ptr := No_Location) return Boolean
172
   is
173
      Name_On_Separate_Line : Boolean;
174
      --  Set True if the name on an END line is on a separate source line
175
      --  from the END. This is highly suspicious, but is allowed. The point
176
      --  is that we want to make sure that we don't just have a missing
177
      --  semicolon misleading us into swallowing an identifier from the
178
      --  following line.
179
 
180
      Name_Scan_State : Saved_Scan_State;
181
      --  Save state at start of name if Name_On_Separate_Line is TRUE
182
 
183
      Span_Node : constant Node_Id := Scope.Table (Scope.Last).Node;
184
 
185
   begin
186
      End_Labl_Present := False;
187
      End_Labl := Empty;
188
 
189
      --  Our first task is to scan out the END sequence if one is present.
190
      --  If none is present, signal by setting End_Type to E_Dummy.
191
 
192
      if Token /= Tok_End then
193
         End_Type := E_Dummy;
194
 
195
      else
196
         Save_Scan_State (Scan_State); -- at END
197
         End_Sloc := Token_Ptr;
198
         End_Column := Start_Column;
199
         End_OK := True;
200
         Scan; -- past END
201
 
202
         --  Set End_Span if expected. note that this will be useless
203
         --  if we do not have the right ending keyword, but in this
204
         --  case we have a malformed program anyway, and the setting
205
         --  of End_Span will simply be unreliable in this case anyway.
206
 
207
         if Present (Span_Node) then
208
            Set_End_Location (Span_Node, Token_Ptr);
209
         end if;
210
 
211
         --  Cases of keywords where no label is allowed
212
 
213
         if Token = Tok_Case then
214
            End_Type := E_Case;
215
            Scan; -- past CASE
216
 
217
         elsif Token = Tok_If then
218
            End_Type := E_If;
219
            Scan; -- past IF
220
 
221
         elsif Token = Tok_Record then
222
            End_Type := E_Record;
223
            Scan; -- past RECORD
224
 
225
         elsif Token = Tok_Return then
226
            End_Type := E_Return;
227
            Scan; -- past RETURN
228
 
229
         elsif Token = Tok_Select then
230
            End_Type := E_Select;
231
            Scan; -- past SELECT
232
 
233
         --  Cases which do allow labels
234
 
235
         else
236
            --  LOOP
237
 
238
            if Token = Tok_Loop then
239
               Scan; -- past LOOP
240
               End_Type := E_Loop;
241
 
242
            --  FOR or WHILE allowed (signalling error) to substitute for LOOP
243
            --  if on the same line as the END.
244
 
245
            elsif (Token = Tok_For or else Token = Tok_While)
246
              and then not Token_Is_At_Start_Of_Line
247
            then
248
               Scan; -- past FOR or WHILE
249
               End_Type := E_Loop;
250
               End_OK := False;
251
 
252
            --  Cases with no keyword
253
 
254
            else
255
               End_Type := E_Name;
256
            end if;
257
 
258
            --  Now see if a name is present
259
 
260
            if Token = Tok_Identifier or else
261
               Token = Tok_String_Literal or else
262
               Token = Tok_Operator_Symbol
263
            then
264
               if Token_Is_At_Start_Of_Line then
265
                  Name_On_Separate_Line := True;
266
                  Save_Scan_State (Name_Scan_State);
267
               else
268
                  Name_On_Separate_Line := False;
269
               end if;
270
 
271
               End_Labl := P_Designator;
272
               End_Labl_Present := True;
273
 
274
               --  We have now scanned out a name. Here is where we do a check
275
               --  to catch the cases like:
276
               --
277
               --    end loop
278
               --    X := 3;
279
               --
280
               --  where the missing semicolon might make us swallow up the X
281
               --  as a bogus end label. In a situation like this, where the
282
               --  apparent name is on a separate line, we accept it only if
283
               --  it matches the label and is followed by a semicolon.
284
 
285
               if Name_On_Separate_Line then
286
                  if Token /= Tok_Semicolon or else
287
                    not Same_Label (End_Labl, Scope.Table (Scope.Last).Labl)
288
                  then
289
                     Restore_Scan_State (Name_Scan_State);
290
                     End_Labl := Empty;
291
                     End_Labl_Present := False;
292
                  end if;
293
               end if;
294
 
295
            --  Here for case of name allowed, but no name present. We will
296
            --  supply an implicit matching name, with source location set
297
            --  to the scan location past the END token.
298
 
299
            else
300
               End_Labl := Scope.Table (Scope.Last).Labl;
301
 
302
               if End_Labl > Empty_Or_Error then
303
 
304
                  --  The task here is to construct a designator from the
305
                  --  opening label, with the components all marked as not
306
                  --  from source, and Is_End_Label set in the identifier
307
                  --  or operator symbol. The location for all components
308
                  --  is the current token location.
309
 
310
                  --  Case of child unit name
311
 
312
                  if Nkind (End_Labl) = N_Defining_Program_Unit_Name then
313
                     Child_End : declare
314
                        Eref : constant Node_Id :=
315
                                 Make_Identifier (Token_Ptr,
316
                                   Chars =>
317
                                     Chars (Defining_Identifier (End_Labl)));
318
 
319
                        function Copy_Name (N : Node_Id) return Node_Id;
320
                        --  Copies a selected component or identifier
321
 
322
                        ---------------
323
                        -- Copy_Name --
324
                        ---------------
325
 
326
                        function Copy_Name (N : Node_Id) return Node_Id is
327
                           R : Node_Id;
328
 
329
                        begin
330
                           if Nkind (N) = N_Selected_Component then
331
                              return
332
                                Make_Selected_Component (Token_Ptr,
333
                                  Prefix        =>
334
                                    Copy_Name (Prefix (N)),
335
                                  Selector_Name =>
336
                                    Copy_Name (Selector_Name (N)));
337
 
338
                           else
339
                              R := Make_Identifier (Token_Ptr, Chars (N));
340
                              Set_Comes_From_Source (N, False);
341
                              return R;
342
                           end if;
343
                        end Copy_Name;
344
 
345
                     --  Start of processing for Child_End
346
 
347
                     begin
348
                        Set_Comes_From_Source (Eref, False);
349
 
350
                        End_Labl :=
351
                          Make_Designator (Token_Ptr,
352
                            Name       => Copy_Name (Name (End_Labl)),
353
                            Identifier => Eref);
354
                     end Child_End;
355
 
356
                  --  Simple identifier case
357
 
358
                  elsif Nkind (End_Labl) = N_Defining_Identifier
359
                    or else Nkind (End_Labl) = N_Identifier
360
                  then
361
                     End_Labl := Make_Identifier (Token_Ptr, Chars (End_Labl));
362
 
363
                  elsif Nkind (End_Labl) = N_Defining_Operator_Symbol
364
                    or else Nkind (End_Labl) = N_Operator_Symbol
365
                  then
366
                     Get_Decoded_Name_String (Chars (End_Labl));
367
 
368
                     End_Labl :=
369
                       Make_Operator_Symbol (Token_Ptr,
370
                         Chars  => Chars (End_Labl),
371
                         Strval => String_From_Name_Buffer);
372
                  end if;
373
 
374
                  Set_Comes_From_Source (End_Labl, False);
375
                  End_Labl_Present := False;
376
 
377
                  --  Do style check for label permitted but not present. Note:
378
                  --  for the case of a block statement, the label is required
379
                  --  to be repeated, and this legality rule is enforced
380
                  --  independently.
381
 
382
                  if Style_Check
383
                    and then End_Type = E_Name
384
                    and then Explicit_Start_Label (Scope.Last)
385
                    and then Nkind (Parent (Scope.Table (Scope.Last).Labl))
386
                               /= N_Block_Statement
387
                  then
388
                     Style.No_End_Name (Scope.Table (Scope.Last).Labl);
389
                  end if;
390
               end if;
391
            end if;
392
         end if;
393
 
394
         --  Deal with terminating aspect specifications and following semi-
395
         --  colon. We skip this in the case of END RECORD, since in this
396
         --  case the aspect specifications and semicolon are handled at
397
         --  a higher level.
398
 
399
         if End_Type /= E_Record then
400
 
401
            --  Scan aspect specifications
402
 
403
            if Aspect_Specifications_Present then
404
 
405
               --  Aspect specifications not allowed
406
 
407
               if No (Decl) then
408
 
409
                  --  Package declaration case
410
 
411
                  if Is_Loc /= No_Location then
412
                     Error_Msg_SC
413
                       ("misplaced aspects for package declaration");
414
                     Error_Msg
415
                       ("info: aspect specifications belong here", Is_Loc);
416
                     P_Aspect_Specifications (Empty);
417
 
418
                  --  Other cases where aspect specifications are not allowed
419
 
420
                  else
421
                     P_Aspect_Specifications (Error);
422
                  end if;
423
 
424
               --  Aspect specifications allowed
425
 
426
               else
427
                  P_Aspect_Specifications (Decl);
428
               end if;
429
 
430
            --  If no aspect specifications, must have a semicolon
431
 
432
            elsif End_Type /= E_Record then
433
               if Token = Tok_Semicolon then
434
                  T_Semicolon;
435
 
436
               --  Semicolon is missing. If the missing semicolon is at the end
437
               --  of the line, i.e. we are at the start of the line now, then
438
               --  a missing semicolon gets flagged, but is not serious enough
439
               --  to consider the END statement to be bad in the sense that we
440
               --  are dealing with (i.e. to be suspicious that this END is not
441
               --  the END statement we are looking for).
442
 
443
               --  Similarly, if we are at a colon, we flag it but a colon for
444
               --  a semicolon is not serious enough to consider the END to be
445
               --  incorrect. Same thing for a period in place of a semicolon.
446
 
447
               elsif Token_Is_At_Start_Of_Line
448
                 or else Token = Tok_Colon
449
                 or else Token = Tok_Dot
450
               then
451
                  T_Semicolon;
452
 
453
               --  If the missing semicolon is not at the start of the line,
454
               --  then we consider the END line to be dubious in this sense.
455
 
456
               else
457
                  End_OK := False;
458
               end if;
459
            end if;
460
         end if;
461
      end if;
462
 
463
      --  Now we call the Pop_End_Context routine to get a recommendation
464
      --  as to what should be done with the END sequence we have scanned.
465
 
466
      Pop_End_Context;
467
 
468
      --  Remaining action depends on End_Action set by Pop_End_Context
469
 
470
      case End_Action is
471
 
472
         --  Accept_As_Scanned. In this case, Pop_End_Context left Token
473
         --  pointing past the last token of a syntactically correct END
474
 
475
         when Accept_As_Scanned =>
476
 
477
            --  Syntactically correct included the possibility of a missing
478
            --  semicolon. If we do have a missing semicolon, then we have
479
            --  already given a message, but now we scan out possible rubbish
480
            --  on the same line as the END
481
 
482
            while not Token_Is_At_Start_Of_Line
483
              and then Prev_Token /= Tok_Record
484
              and then Prev_Token /= Tok_Semicolon
485
              and then Token /= Tok_End
486
              and then Token /= Tok_EOF
487
            loop
488
               Scan; -- past junk
489
            end loop;
490
 
491
            return True;
492
 
493
         --  Insert_And_Accept. In this case, Pop_End_Context has reset Token
494
         --  to point to the start of the END sequence, and recommends that it
495
         --  be left in place to satisfy an outer scope level END. This means
496
         --  that we proceed as though an END were present, and leave the scan
497
         --  pointer unchanged.
498
 
499
         when Insert_And_Accept =>
500
            return True;
501
 
502
         --  Skip_And_Accept. In this case, Pop_End_Context has reset Token
503
         --  to point to the start of the END sequence. This END sequence is
504
         --  syntactically incorrect, and an appropriate error message has
505
         --  already been posted. Pop_End_Context recommends accepting the
506
         --  END sequence as the one we want, so we skip past it and then
507
         --  proceed as though an END were present.
508
 
509
         when Skip_And_Accept =>
510
            End_Skip;
511
            return True;
512
 
513
         --  Skip_And_Reject. In this case, Pop_End_Context has reset Token
514
         --  to point to the start of the END sequence. This END sequence is
515
         --  syntactically incorrect, and an appropriate error message has
516
         --  already been posted. Pop_End_Context recommends entirely ignoring
517
         --  this END sequence, so we skip past it and then return False, since
518
         --  as far as the caller is concerned, no END sequence is present.
519
 
520
         when Skip_And_Reject =>
521
            End_Skip;
522
            return False;
523
      end case;
524
   end Check_End;
525
 
526
   --------------
527
   -- End Skip --
528
   --------------
529
 
530
   --  This procedure skips past an END sequence. On entry Token contains
531
   --  Tok_End, and we know that the END sequence is syntactically incorrect,
532
   --  and that an appropriate error message has already been posted. The
533
   --  mission is simply to position the scan pointer to be the best guess of
534
   --  the position after the END sequence. We do not issue any additional
535
   --  error messages while carrying this out.
536
 
537
   --  Error recovery: does not raise Error_Resync
538
 
539
   procedure End_Skip is
540
   begin
541
      Scan; -- past END
542
 
543
      --  If the scan past the END leaves us on the next line, that's probably
544
      --  where we should quit the scan, since it is likely that what we have
545
      --  is a missing semicolon. Consider the following:
546
 
547
      --       END
548
      --       Process_Input;
549
 
550
      --  This will have looked like a syntactically valid END sequence to the
551
      --  initial scan of the END, but subsequent checking will have determined
552
      --  that the label Process_Input is not an appropriate label. The real
553
      --  error is a missing semicolon after the END, and by leaving the scan
554
      --  pointer just past the END, we will improve the error recovery.
555
 
556
      if Token_Is_At_Start_Of_Line then
557
         return;
558
      end if;
559
 
560
      --  If there is a semicolon after the END, scan it out and we are done
561
 
562
      if Token = Tok_Semicolon then
563
         T_Semicolon;
564
         return;
565
      end if;
566
 
567
      --  Otherwise skip past a token after the END on the same line. Note
568
      --  that we do not eat a token on the following line since it seems
569
      --  very unlikely in any case that the END gets separated from its
570
      --  token, and we do not want to swallow up a keyword that starts a
571
      --  legitimate construct following the bad END.
572
 
573
      if not Token_Is_At_Start_Of_Line
574
        and then
575
 
576
         --  Cases of normal tokens following an END
577
 
578
          (Token = Tok_Case   or else
579
           Token = Tok_For    or else
580
           Token = Tok_If     or else
581
           Token = Tok_Loop   or else
582
           Token = Tok_Record or else
583
           Token = Tok_Select or else
584
 
585
         --  Cases of bogus keywords ending loops
586
 
587
           Token = Tok_For    or else
588
           Token = Tok_While  or else
589
 
590
         --  Cases of operator symbol names without quotes
591
 
592
           Token = Tok_Abs    or else
593
           Token = Tok_And    or else
594
           Token = Tok_Mod    or else
595
           Token = Tok_Not    or else
596
           Token = Tok_Or     or else
597
           Token = Tok_Xor)
598
 
599
      then
600
         Scan; -- past token after END
601
 
602
         --  If that leaves us on the next line, then we are done. This is the
603
         --  same principle described above for the case of END at line end
604
 
605
         if Token_Is_At_Start_Of_Line then
606
            return;
607
 
608
         --  If we just scanned out record, then we are done, since the
609
         --  semicolon after END RECORD is not part of the END sequence
610
 
611
         elsif Prev_Token = Tok_Record then
612
            return;
613
 
614
         --  If we have a semicolon, scan it out and we are done
615
 
616
         elsif Token = Tok_Semicolon then
617
            T_Semicolon;
618
            return;
619
         end if;
620
      end if;
621
 
622
      --  Check for a label present on the same line
623
 
624
      loop
625
         if Token_Is_At_Start_Of_Line then
626
            return;
627
         end if;
628
 
629
         if Token /= Tok_Identifier
630
           and then Token /= Tok_Operator_Symbol
631
           and then Token /= Tok_String_Literal
632
         then
633
            exit;
634
         end if;
635
 
636
         Scan; -- past identifier, operator symbol or string literal
637
 
638
         if Token_Is_At_Start_Of_Line then
639
            return;
640
         elsif Token = Tok_Dot then
641
            Scan; -- past dot
642
         end if;
643
      end loop;
644
 
645
      --  Skip final semicolon
646
 
647
      if Token = Tok_Semicolon then
648
         T_Semicolon;
649
 
650
      --  If we don't have a final semicolon, skip until we either encounter
651
      --  an END token, or a semicolon or the start of the next line. This
652
      --  allows general junk to follow the end line (normally it is hard to
653
      --  think that anyone will put anything deliberate here, and remember
654
      --  that we know there is a missing semicolon in any case). We also
655
      --  quite on an EOF (or else we would get stuck in an infinite loop
656
      --  if there is no line end at the end of the last line of the file)
657
 
658
      else
659
         while Token /= Tok_End
660
           and then Token /= Tok_EOF
661
           and then Token /= Tok_Semicolon
662
           and then not Token_Is_At_Start_Of_Line
663
         loop
664
            Scan; -- past junk token on same line
665
         end loop;
666
      end if;
667
 
668
      return;
669
   end End_Skip;
670
 
671
   --------------------
672
   -- End Statements --
673
   --------------------
674
 
675
   --  This procedure is called when END is required or expected to terminate
676
   --  a sequence of statements. The caller has already made an appropriate
677
   --  entry on the scope stack to describe the expected form of the END.
678
   --  End_Statements should only be used in cases where the only appropriate
679
   --  terminator is END.
680
 
681
   --  Error recovery: cannot raise Error_Resync;
682
 
683
   procedure End_Statements
684
     (Parent  : Node_Id    := Empty;
685
      Decl    : Node_Id    := Empty;
686
      Is_Sloc : Source_Ptr := No_Location)
687
   is
688
   begin
689
      --  This loop runs more than once in the case where Check_End rejects
690
      --  the END sequence, as indicated by Check_End returning False.
691
 
692
      loop
693
         if Check_End (Decl, Is_Sloc) then
694
            if Present (Parent) then
695
               Set_End_Label (Parent, End_Labl);
696
            end if;
697
 
698
            return;
699
         end if;
700
 
701
         --  Extra statements past the bogus END are discarded. This is not
702
         --  ideal for maximum error recovery, but it's too much trouble to
703
         --  find an appropriate place to put them!
704
 
705
         Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
706
      end loop;
707
   end End_Statements;
708
 
709
   ------------------------
710
   -- Evaluate End Entry --
711
   ------------------------
712
 
713
   procedure Evaluate_End_Entry (SS_Index : Nat) is
714
   begin
715
      Column_OK := (End_Column = Scope.Table (SS_Index).Ecol);
716
 
717
      Token_OK  := (End_Type = Scope.Table (SS_Index).Etyp or else
718
                     (End_Type = E_Name and then
719
                       Scope.Table (SS_Index).Etyp >= E_Name));
720
 
721
      Label_OK := End_Labl_Present
722
                    and then
723
                      (Same_Label (End_Labl, Scope.Table (SS_Index).Labl)
724
                        or else Scope.Table (SS_Index).Labl = Error);
725
 
726
      --  Compute setting of Syntax_OK. We definitely have a syntax error
727
      --  if the Token does not match properly or if P_End_Scan detected
728
      --  a syntax error such as a missing semicolon.
729
 
730
      if not Token_OK or not End_OK then
731
         Syntax_OK := False;
732
 
733
      --  Final check is that label is OK. Certainly it is OK if there
734
      --  was an exact match on the label (the END label = the stack label)
735
 
736
      elsif Label_OK then
737
         Syntax_OK := True;
738
 
739
      --  Case of label present
740
 
741
      elsif End_Labl_Present then
742
 
743
         --  If probably misspelling, then complain, and pretend it is OK
744
 
745
         declare
746
            Nam : constant Node_Or_Entity_Id := Scope.Table (SS_Index).Labl;
747
 
748
         begin
749
            if Nkind (End_Labl) in N_Has_Chars
750
              and then Comes_From_Source (Nam)
751
              and then Nkind (Nam) in N_Has_Chars
752
              and then Chars (End_Labl) > Error_Name
753
              and then Chars (Nam) > Error_Name
754
            then
755
               Error_Msg_Name_1 := Chars (Nam);
756
 
757
               if Error_Msg_Name_1 > Error_Name then
758
                  if Is_Bad_Spelling_Of (Chars (Nam), Chars (End_Labl)) then
759
                     Error_Msg_Name_1 := Chars (Nam);
760
                     Error_Msg_N -- CODEFIX
761
                       ("misspelling of %", End_Labl);
762
                     Syntax_OK := True;
763
                     return;
764
                  end if;
765
               end if;
766
            end if;
767
         end;
768
 
769
         Syntax_OK := False;
770
 
771
      --  Otherwise we have cases of no label on the END line. For the loop
772
      --  case, this is acceptable only if the loop is unlabeled.
773
 
774
      elsif End_Type = E_Loop then
775
         Syntax_OK := not Explicit_Start_Label (SS_Index);
776
 
777
      --  Cases where a label is definitely allowed on the END line
778
 
779
      elsif End_Type = E_Name then
780
         Syntax_OK := (not Explicit_Start_Label (SS_Index))
781
                         or else
782
                      (not Scope.Table (SS_Index).Lreq);
783
 
784
      --  Otherwise we have cases which don't allow labels anyway, so we
785
      --  certainly accept an END which does not have a label.
786
 
787
      else
788
         Syntax_OK := True;
789
      end if;
790
   end Evaluate_End_Entry;
791
 
792
   --------------------------
793
   -- Explicit_Start_Label --
794
   --------------------------
795
 
796
   function Explicit_Start_Label (SS_Index : Nat) return Boolean is
797
      L    : constant Node_Id := Scope.Table (SS_Index).Labl;
798
      Etyp : constant SS_End_Type := Scope.Table (SS_Index).Etyp;
799
 
800
   begin
801
      if No (L) then
802
         return False;
803
 
804
      --  In the following test we protect the call to Comes_From_Source
805
      --  against lines containing previously reported syntax errors.
806
 
807
      elsif (Etyp = E_Loop          or else
808
             Etyp = E_Name          or else
809
             Etyp = E_Suspicious_Is or else
810
             Etyp = E_Bad_Is)
811
         and then Comes_From_Source (L)
812
      then
813
         return True;
814
 
815
      else
816
         return False;
817
      end if;
818
   end Explicit_Start_Label;
819
 
820
   ------------------------
821
   -- Output_End_Deleted --
822
   ------------------------
823
 
824
   procedure Output_End_Deleted is
825
   begin
826
      if End_Type = E_Loop then
827
         Error_Msg_SC ("no LOOP for this `END LOOP`!");
828
 
829
      elsif End_Type = E_Case then
830
         Error_Msg_SC ("no CASE for this `END CASE`");
831
 
832
      elsif End_Type = E_If then
833
         Error_Msg_SC ("no IF for this `END IF`!");
834
 
835
      elsif End_Type = E_Record then
836
         Error_Msg_SC ("no RECORD for this `END RECORD`!");
837
 
838
      elsif End_Type = E_Return then
839
         Error_Msg_SC ("no RETURN for this `END RETURN`!");
840
 
841
      elsif End_Type = E_Select then
842
         Error_Msg_SC ("no SELECT for this `END SELECT`!");
843
 
844
      else
845
         Error_Msg_SC ("no BEGIN for this END!");
846
      end if;
847
   end Output_End_Deleted;
848
 
849
   -------------------------
850
   -- Output_End_Expected --
851
   -------------------------
852
 
853
   procedure Output_End_Expected (Ins : Boolean) is
854
      End_Type : SS_End_Type;
855
 
856
   begin
857
      --  Suppress message if this was a potentially junk entry (e.g. a record
858
      --  entry where no record keyword was present).
859
 
860
      if Scope.Table (Scope.Last).Junk then
861
         return;
862
      end if;
863
 
864
      End_Type := Scope.Table (Scope.Last).Etyp;
865
      Error_Msg_Col  := Scope.Table (Scope.Last).Ecol;
866
      Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
867
 
868
      if Explicit_Start_Label (Scope.Last) then
869
         Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
870
      else
871
         Error_Msg_Node_1 := Empty;
872
      end if;
873
 
874
      --  Suppress message if error was posted on opening label
875
 
876
      if Error_Msg_Node_1 > Empty_Or_Error
877
        and then Error_Posted (Error_Msg_Node_1)
878
      then
879
         return;
880
      end if;
881
 
882
      if End_Type = E_Case then
883
         Error_Msg_SC -- CODEFIX
884
           ("`END CASE;` expected@ for CASE#!");
885
 
886
      elsif End_Type = E_If then
887
         Error_Msg_SC -- CODEFIX
888
           ("`END IF;` expected@ for IF#!");
889
 
890
      elsif End_Type = E_Loop then
891
         if Error_Msg_Node_1 = Empty then
892
            Error_Msg_SC -- CODEFIX
893
              ("`END LOOP;` expected@ for LOOP#!");
894
         else
895
            Error_Msg_SC -- CODEFIX
896
              ("`END LOOP &;` expected@!");
897
         end if;
898
 
899
      elsif End_Type = E_Record then
900
         Error_Msg_SC -- CODEFIX
901
           ("`END RECORD;` expected@ for RECORD#!");
902
 
903
      elsif End_Type = E_Return then
904
         Error_Msg_SC -- CODEFIX
905
           ("`END RETURN;` expected@ for RETURN#!");
906
 
907
      elsif End_Type = E_Select then
908
         Error_Msg_SC -- CODEFIX
909
           ("`END SELECT;` expected@ for SELECT#!");
910
 
911
      --  All remaining cases are cases with a name (we do not treat the
912
      --  suspicious is cases specially for a replaced end, only for an
913
      --  inserted end).
914
 
915
      elsif End_Type = E_Name or else not Ins then
916
         if Error_Msg_Node_1 = Empty then
917
            Error_Msg_SC -- CODEFIX
918
              ("`END;` expected@ for BEGIN#!");
919
         else
920
            Error_Msg_SC -- CODEFIX
921
              ("`END &;` expected@!");
922
         end if;
923
 
924
      --  The other possibility is a missing END for a subprogram with a
925
      --  suspicious IS (that probably should have been a semicolon). The
926
      --  missing IS confirms the suspicion!
927
 
928
      else -- End_Type = E_Suspicious_Is or E_Bad_Is
929
         Scope.Table (Scope.Last).Etyp := E_Bad_Is;
930
      end if;
931
   end Output_End_Expected;
932
 
933
   ------------------------
934
   -- Output_End_Missing --
935
   ------------------------
936
 
937
   procedure Output_End_Missing is
938
      End_Type : SS_End_Type;
939
 
940
   begin
941
      --  Suppress message if this was a potentially junk entry (e.g. a record
942
      --  entry where no record keyword was present).
943
 
944
      if Scope.Table (Scope.Last).Junk then
945
         return;
946
      end if;
947
 
948
      End_Type := Scope.Table (Scope.Last).Etyp;
949
      Error_Msg_Sloc   := Scope.Table (Scope.Last).Sloc;
950
 
951
      if Explicit_Start_Label (Scope.Last) then
952
         Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
953
      else
954
         Error_Msg_Node_1 := Empty;
955
      end if;
956
 
957
      if End_Type = E_Case then
958
         Error_Msg_BC ("missing `END CASE;` for CASE#!");
959
 
960
      elsif End_Type = E_If then
961
         Error_Msg_BC ("missing `END IF;` for IF#!");
962
 
963
      elsif End_Type = E_Loop then
964
         if Error_Msg_Node_1 = Empty then
965
            Error_Msg_BC ("missing `END LOOP;` for LOOP#!");
966
         else
967
            Error_Msg_BC ("missing `END LOOP &;`!");
968
         end if;
969
 
970
      elsif End_Type = E_Record then
971
         Error_Msg_SC
972
           ("missing `END RECORD;` for RECORD#!");
973
 
974
      elsif End_Type = E_Return then
975
         Error_Msg_SC
976
           ("missing `END RETURN;` for RETURN#!");
977
 
978
      elsif End_Type = E_Select then
979
         Error_Msg_BC
980
           ("missing `END SELECT;` for SELECT#!");
981
 
982
      elsif End_Type = E_Name then
983
         if Error_Msg_Node_1 = Empty then
984
            Error_Msg_BC ("missing `END;` for BEGIN#!");
985
         else
986
            Error_Msg_BC ("missing `END &;`!");
987
         end if;
988
 
989
      else -- End_Type = E_Suspicious_Is or E_Bad_Is
990
         Scope.Table (Scope.Last).Etyp := E_Bad_Is;
991
      end if;
992
   end Output_End_Missing;
993
 
994
   ---------------------
995
   -- Pop_End_Context --
996
   ---------------------
997
 
998
   procedure Pop_End_Context is
999
 
1000
      Pretty_Good : Boolean;
1001
      --  This flag is set True if the END sequence is syntactically incorrect,
1002
      --  but is (from a heuristic point of view), pretty likely to be simply
1003
      --  a misspelling of the intended END.
1004
 
1005
      Outer_Match : Boolean;
1006
      --  This flag is set True if we decide that the current END sequence
1007
      --  belongs to some outer level entry in the scope stack, and thus
1008
      --  we will NOT eat it up in matching the current expected END.
1009
 
1010
   begin
1011
      --  If not at END, then output END expected message
1012
 
1013
      if End_Type = E_Dummy then
1014
         Output_End_Missing;
1015
         Pop_Scope_Stack;
1016
         End_Action := Insert_And_Accept;
1017
         return;
1018
 
1019
      --  Otherwise we do have an END present
1020
 
1021
      else
1022
         --  A special check. If we have END; followed by an end of file,
1023
         --  WITH or SEPARATE, then if we are not at the outer level, then
1024
         --  we have a syntax error. Consider the example:
1025
 
1026
         --   ...
1027
         --      declare
1028
         --         X : Integer;
1029
         --      begin
1030
         --         X := Father (A);
1031
         --         Process (X, X);
1032
         --   end;
1033
         --   with Package1;
1034
         --   ...
1035
 
1036
         --  Now the END; here is a syntactically correct closer for the
1037
         --  declare block, but if we eat it up, then we obviously have
1038
         --  a missing END for the outer context (since WITH can only appear
1039
         --  at the outer level.
1040
 
1041
         --  In this situation, we always reserve the END; for the outer level,
1042
         --  even if it is in the wrong column. This is because it's much more
1043
         --  useful to have the error message point to the DECLARE than to the
1044
         --  package header in this case.
1045
 
1046
         --  We also reserve an end with a name before the end of file if the
1047
         --  name is the one we expect at the outer level.
1048
 
1049
         if (Token = Tok_EOF  or else
1050
             Token = Tok_With or else
1051
             Token = Tok_Separate)
1052
           and then End_Type >= E_Name
1053
           and then (not End_Labl_Present
1054
                      or else Same_Label (End_Labl, Scope.Table (1).Labl))
1055
           and then Scope.Last > 1
1056
         then
1057
            Restore_Scan_State (Scan_State); -- to END
1058
            Output_End_Expected (Ins => True);
1059
            Pop_Scope_Stack;
1060
            End_Action := Insert_And_Accept;
1061
            return;
1062
         end if;
1063
 
1064
         --  Otherwise we go through the normal END evaluation procedure
1065
 
1066
         Evaluate_End_Entry (Scope.Last);
1067
 
1068
         --  If top entry in stack is syntactically correct, then we have
1069
         --  scanned it out and everything is fine. This is the required
1070
         --  action to properly process correct Ada programs.
1071
 
1072
         if Syntax_OK then
1073
 
1074
            --  Complain if checking columns and END is not in right column.
1075
            --  Right in this context means exactly right, or on the same
1076
            --  line as the opener.
1077
 
1078
            if RM_Column_Check then
1079
               if End_Column /= Scope.Table (Scope.Last).Ecol
1080
                 and then Current_Line_Start > Scope.Table (Scope.Last).Sloc
1081
 
1082
               --  A special case, for END RECORD, we are also allowed to
1083
               --  line up with the TYPE keyword opening the declaration.
1084
 
1085
                 and then (Scope.Table (Scope.Last).Etyp /= E_Record
1086
                            or else Get_Column_Number (End_Sloc) /=
1087
                                    Get_Column_Number (Type_Token_Location))
1088
               then
1089
                  Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
1090
                  Error_Msg
1091
                    ("(style) END in wrong column, should be@", End_Sloc);
1092
               end if;
1093
            end if;
1094
 
1095
            --  One final check. If the end had a label, check for an exact
1096
            --  duplicate of this end sequence, and if so, skip it with an
1097
            --  appropriate message.
1098
 
1099
            if End_Labl_Present and then Token = Tok_End then
1100
               declare
1101
                  Scan_State : Saved_Scan_State;
1102
                  End_Loc    : constant Source_Ptr := Token_Ptr;
1103
                  Nxt_Labl   : Node_Id;
1104
                  Dup_Found  : Boolean := False;
1105
 
1106
               begin
1107
                  Save_Scan_State (Scan_State);
1108
 
1109
                  Scan; -- past END
1110
 
1111
                  if Token = Tok_Identifier
1112
                    or else Token = Tok_Operator_Symbol
1113
                  then
1114
                     Nxt_Labl := P_Designator;
1115
 
1116
                     --  We only consider it an error if the label is a match
1117
                     --  and would be wrong for the level one above us, and
1118
                     --  the indentation is the same.
1119
 
1120
                     if Token = Tok_Semicolon
1121
                       and then Same_Label (End_Labl, Nxt_Labl)
1122
                       and then End_Column = Start_Column
1123
                       and then
1124
                         (Scope.Last = 1
1125
                            or else
1126
                              (not Explicit_Start_Label (Scope.Last - 1))
1127
                                 or else
1128
                              (not Same_Label
1129
                                     (End_Labl,
1130
                                      Scope.Table (Scope.Last - 1).Labl)))
1131
                     then
1132
                        T_Semicolon;
1133
                        Error_Msg ("duplicate end line ignored", End_Loc);
1134
                        Dup_Found := True;
1135
                     end if;
1136
                  end if;
1137
 
1138
                  if not Dup_Found then
1139
                     Restore_Scan_State (Scan_State);
1140
                  end if;
1141
               end;
1142
            end if;
1143
 
1144
            --  All OK, so return to caller indicating END is OK
1145
 
1146
            Pop_Scope_Stack;
1147
            End_Action := Accept_As_Scanned;
1148
            return;
1149
         end if;
1150
 
1151
         --  If that check failed, then we definitely have an error. The issue
1152
         --  is how to choose among three possible courses of action:
1153
 
1154
         --   1. Ignore the current END text completely, scanning past it,
1155
         --      deciding that it belongs neither to the current context,
1156
         --      nor to any outer context.
1157
 
1158
         --   2. Accept the current END text, scanning past it, and issuing
1159
         --      an error message that it does not have the right form.
1160
 
1161
         --   3. Leave the current END text in place, NOT scanning past it,
1162
         --      issuing an error message indicating the END expected for the
1163
         --      current context. In this case, the END is available to match
1164
         --      some outer END context.
1165
 
1166
         --  From a correct functioning point of view, it does not make any
1167
         --  difference which of these three approaches we take, the program
1168
         --  will work correctly in any case. However, making an accurate
1169
         --  choice among these alternatives, i.e. choosing the one that
1170
         --  corresponds to what the programmer had in mind, does make a
1171
         --  significant difference in the quality of error recovery.
1172
 
1173
         Restore_Scan_State (Scan_State); -- to END
1174
 
1175
         --  First we see how good the current END entry is with respect to
1176
         --  what we expect. It is considered pretty good if the token is OK,
1177
         --  and either the label or the column matches. An END for RECORD is
1178
         --  always considered to be pretty good in the record case. This is
1179
         --  because not only does a record disallow a nested structure, but
1180
         --  also it is unlikely that such nesting could occur by accident.
1181
 
1182
         Pretty_Good := (Token_OK and (Column_OK or Label_OK))
1183
                          or else Scope.Table (Scope.Last).Etyp = E_Record;
1184
 
1185
         --  Next check, if there is a deeper entry in the stack which
1186
         --  has a very high probability of being acceptable, then insert
1187
         --  the END entry we want, leaving the higher level entry for later
1188
 
1189
         for J in reverse 1 .. Scope.Last - 1 loop
1190
            Evaluate_End_Entry (J);
1191
 
1192
            --  To even consider the deeper entry to be immediately acceptable,
1193
            --  it must be syntactically correct. Furthermore it must either
1194
            --  have a correct label, or the correct column. If the current
1195
            --  entry was a close match (Pretty_Good set), then we are even
1196
            --  more strict in accepting the outer level one: even if it has
1197
            --  the right label, it must have the right column as well.
1198
 
1199
            if Syntax_OK then
1200
               if Pretty_Good then
1201
                  Outer_Match := Label_OK and Column_OK;
1202
               else
1203
                  Outer_Match := Label_OK or Column_OK;
1204
               end if;
1205
            else
1206
               Outer_Match := False;
1207
            end if;
1208
 
1209
            --  If the outer entry does convincingly match the END text, then
1210
            --  back up the scan to the start of the END sequence, issue an
1211
            --  error message indicating the END we expected, and return with
1212
            --  Token pointing to the END (case 3 from above discussion).
1213
 
1214
            if Outer_Match then
1215
               Output_End_Missing;
1216
               Pop_Scope_Stack;
1217
               End_Action := Insert_And_Accept;
1218
               return;
1219
            end if;
1220
         end loop;
1221
 
1222
         --  Here we have a situation in which the current END entry is
1223
         --  syntactically incorrect, but there is no deeper entry in the
1224
         --  END stack which convincingly matches it.
1225
 
1226
         --  If the END text was judged to be a Pretty_Good match for the
1227
         --  expected token or if it appears left of the expected column,
1228
         --  then we will accept it as the one we want, scanning past it, even
1229
         --  though it is not completely right (we issue a message showing what
1230
         --  we expected it to be). This is action 2 from the discussion above.
1231
         --  There is one other special case to consider: the LOOP case.
1232
         --  Consider the example:
1233
 
1234
         --     Lbl: loop
1235
         --             null;
1236
         --          end loop;
1237
 
1238
         --  Here the column lines up with Lbl, so END LOOP is to the right,
1239
         --  but it is still acceptable. LOOP is the one case where alignment
1240
         --  practices vary substantially in practice.
1241
 
1242
         if Pretty_Good
1243
            or else End_Column <= Scope.Table (Scope.Last).Ecol
1244
            or else (End_Type = Scope.Table (Scope.Last).Etyp
1245
                        and then End_Type = E_Loop)
1246
         then
1247
            Output_End_Expected (Ins => False);
1248
            Pop_Scope_Stack;
1249
            End_Action := Skip_And_Accept;
1250
            return;
1251
 
1252
         --  Here we have the case where the END is to the right of the
1253
         --  expected column and does not have a correct label to convince
1254
         --  us that it nevertheless belongs to the current scope. For this
1255
         --  we consider that it probably belongs not to the current context,
1256
         --  but to some inner context that was not properly recognized (due to
1257
         --  other syntax errors), and for which no proper scope stack entry
1258
         --  was made. The proper action in this case is to delete the END text
1259
         --  and return False to the caller as a signal to keep on looking for
1260
         --  an acceptable END. This is action 1 from the discussion above.
1261
 
1262
         else
1263
            Output_End_Deleted;
1264
            End_Action := Skip_And_Reject;
1265
            return;
1266
         end if;
1267
      end if;
1268
   end Pop_End_Context;
1269
 
1270
   ----------------
1271
   -- Same_Label --
1272
   ----------------
1273
 
1274
   function Same_Label (Label1, Label2 : Node_Id) return Boolean is
1275
   begin
1276
      if Nkind (Label1) in N_Has_Chars
1277
        and then Nkind (Label2) in N_Has_Chars
1278
      then
1279
         return Chars (Label1) = Chars (Label2);
1280
 
1281
      elsif Nkind (Label1) = N_Selected_Component
1282
        and then Nkind (Label2) = N_Selected_Component
1283
      then
1284
         return Same_Label (Prefix (Label1), Prefix (Label2)) and then
1285
           Same_Label (Selector_Name (Label1), Selector_Name (Label2));
1286
 
1287
      elsif Nkind (Label1) = N_Designator
1288
        and then Nkind (Label2) = N_Defining_Program_Unit_Name
1289
      then
1290
         return Same_Label (Name (Label1), Name (Label2)) and then
1291
           Same_Label (Identifier (Label1), Defining_Identifier (Label2));
1292
 
1293
      else
1294
         return False;
1295
      end if;
1296
   end Same_Label;
1297
 
1298
end Endh;

powered by: WebSVN 2.1.0

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