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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [par-endh.adb] - Blame information for rev 816

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

powered by: WebSVN 2.1.0

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