1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                             P A R . T C H K                              --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2018, 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--  Token scan routines
27
28--  Error recovery: none of the T_xxx or TF_xxx routines raise Error_Resync
29
30separate (Par)
31package body Tchk is
32
33   type Position is (SC, BC, AP);
34   --  Specify position of error message (see Error_Msg_SC/BC/AP)
35
36   -----------------------
37   -- Local Subprograms --
38   -----------------------
39
40   procedure Check_Token (T : Token_Type; P : Position);
41   pragma Inline (Check_Token);
42   --  Called by T_xx routines to check for reserved keyword token. P is the
43   --  position of the error message if the token is missing (see Wrong_Token)
44
45   procedure Wrong_Token (T : Token_Type; P : Position);
46   --  Called when scanning a reserved keyword when the keyword is not present.
47   --  T is the token type for the keyword, and P indicates the position to be
48   --  used to place a message relative to the current token if the keyword is
49   --  not located nearby.
50
51   -----------------
52   -- Check_Token --
53   -----------------
54
55   procedure Check_Token (T : Token_Type; P : Position) is
56   begin
57      if Token = T then
58         Scan;
59         return;
60      else
61         Wrong_Token (T, P);
62      end if;
63   end Check_Token;
64
65   -------------
66   -- T_Abort --
67   -------------
68
69   procedure T_Abort is
70   begin
71      Check_Token (Tok_Abort, SC);
72   end T_Abort;
73
74   -------------
75   -- T_Arrow --
76   -------------
77
78   procedure T_Arrow is
79   begin
80      if Token = Tok_Arrow then
81         Scan;
82
83      --  A little recovery helper, accept then in place of =>
84
85      elsif Token = Tok_Then then
86         Error_Msg_BC -- CODEFIX
87           ("|THEN should be ""='>""");
88         Scan; -- past THEN used in place of =>
89
90      elsif Token = Tok_Colon_Equal then
91         Error_Msg_SC -- CODEFIX
92           ("|"":="" should be ""='>""");
93         Scan; -- past := used in place of =>
94
95      else
96         Error_Msg_AP -- CODEFIX
97           ("missing ""='>""");
98      end if;
99   end T_Arrow;
100
101   ----------
102   -- T_At --
103   ----------
104
105   procedure T_At is
106   begin
107      Check_Token (Tok_At, SC);
108   end T_At;
109
110   ------------
111   -- T_Body --
112   ------------
113
114   procedure T_Body is
115   begin
116      Check_Token (Tok_Body, BC);
117   end T_Body;
118
119   -----------
120   -- T_Box --
121   -----------
122
123   procedure T_Box is
124   begin
125      if Token = Tok_Box then
126         Scan;
127      else
128         Error_Msg_AP -- CODEFIX
129           ("missing ""'<'>""");
130      end if;
131   end T_Box;
132
133   -------------
134   -- T_Colon --
135   -------------
136
137   procedure T_Colon is
138   begin
139      if Token = Tok_Colon then
140         Scan;
141      else
142         Error_Msg_AP -- CODEFIX
143           ("missing "":""");
144      end if;
145   end T_Colon;
146
147   -------------------
148   -- T_Colon_Equal --
149   -------------------
150
151   procedure T_Colon_Equal is
152   begin
153      if Token = Tok_Colon_Equal then
154         Scan;
155
156      elsif Token = Tok_Equal then
157         Error_Msg_SC -- CODEFIX
158           ("|""="" should be "":=""");
159         Scan;
160
161      elsif Token = Tok_Colon then
162         Error_Msg_SC -- CODEFIX
163           ("|"":"" should be "":=""");
164         Scan;
165
166      elsif Token = Tok_Is then
167         Error_Msg_SC -- CODEFIX
168           ("|IS should be "":=""");
169         Scan;
170
171      else
172         Error_Msg_AP -- CODEFIX
173           ("missing "":=""");
174      end if;
175   end T_Colon_Equal;
176
177   -------------
178   -- T_Comma --
179   -------------
180
181   procedure T_Comma is
182   begin
183      if Token = Tok_Comma then
184         Scan;
185
186      else
187         if Token = Tok_Pragma then
188            P_Pragmas_Misplaced;
189         end if;
190
191         if Token = Tok_Comma then
192            Scan;
193         else
194            Error_Msg_AP -- CODEFIX
195              ("missing "",""");
196         end if;
197      end if;
198
199      if Token = Tok_Pragma then
200         P_Pragmas_Misplaced;
201      end if;
202   end T_Comma;
203
204   ---------------
205   -- T_Dot_Dot --
206   ---------------
207
208   procedure T_Dot_Dot is
209   begin
210      if Token = Tok_Dot_Dot then
211         Scan;
212      else
213         Error_Msg_AP -- CODEFIX
214           ("missing ""..""");
215      end if;
216   end T_Dot_Dot;
217
218   -----------
219   -- T_For --
220   -----------
221
222   procedure T_For is
223   begin
224      Check_Token (Tok_For, AP);
225   end T_For;
226
227   -----------------------
228   -- T_Greater_Greater --
229   -----------------------
230
231   procedure T_Greater_Greater is
232   begin
233      if Token = Tok_Greater_Greater then
234         Scan;
235      else
236         Error_Msg_AP -- CODEFIX
237           ("missing ""'>'>""");
238      end if;
239   end T_Greater_Greater;
240
241   ------------------
242   -- T_Identifier --
243   ------------------
244
245   procedure T_Identifier is
246   begin
247      if Token = Tok_Identifier then
248         Scan;
249      elsif Token in Token_Class_Literal then
250         Error_Msg_SC ("identifier expected");
251         Scan;
252      else
253         Error_Msg_AP ("identifier expected");
254      end if;
255   end T_Identifier;
256
257   ----------
258   -- T_In --
259   ----------
260
261   procedure T_In is
262   begin
263      Check_Token (Tok_In, AP);
264   end T_In;
265
266   ----------
267   -- T_Is --
268   ----------
269
270   procedure T_Is is
271   begin
272      Ignore (Tok_Semicolon);
273
274      --  If we have IS scan past it
275
276      if Token = Tok_Is then
277         Scan;
278
279         --  And ignore any following semicolons
280
281         Ignore (Tok_Semicolon);
282
283      --  Allow OF, => or = to substitute for IS with complaint
284
285      elsif Token = Tok_Arrow then
286         Error_Msg_SC -- CODEFIX
287           ("|""=>"" should be IS");
288         Scan; -- past =>
289
290      elsif Token = Tok_Of then
291         Error_Msg_SC -- CODEFIX
292           ("|OF should be IS");
293         Scan; -- past OF
294
295      elsif Token = Tok_Equal then
296         Error_Msg_SC -- CODEFIX
297           ("|""="" should be IS");
298         Scan; -- past =
299
300      else
301         Wrong_Token (Tok_Is, AP);
302      end if;
303
304      --  Ignore extra IS keywords
305
306      while Token = Tok_Is loop
307         Error_Msg_SC -- CODEFIX
308           ("|extra IS ignored");
309         Scan;
310      end loop;
311   end T_Is;
312
313   ------------------
314   -- T_Left_Paren --
315   ------------------
316
317   procedure T_Left_Paren is
318   begin
319      if Token = Tok_Left_Paren then
320         Scan;
321      else
322         Error_Msg_AP -- CODEFIX
323           ("missing ""(""");
324      end if;
325   end T_Left_Paren;
326
327   ------------
328   -- T_Loop --
329   ------------
330
331   procedure T_Loop is
332   begin
333      if Token = Tok_Do then
334         Error_Msg_SC -- CODEFIX
335           ("LOOP expected");
336         Scan;
337      else
338         Check_Token (Tok_Loop, AP);
339      end if;
340   end T_Loop;
341
342   -----------
343   -- T_Mod --
344   -----------
345
346   procedure T_Mod is
347   begin
348      Check_Token (Tok_Mod, AP);
349   end T_Mod;
350
351   -----------
352   -- T_New --
353   -----------
354
355   procedure T_New is
356   begin
357      Check_Token (Tok_New, AP);
358   end T_New;
359
360   ----------
361   -- T_Of --
362   ----------
363
364   procedure T_Of is
365   begin
366      Check_Token (Tok_Of, AP);
367   end T_Of;
368
369   ----------
370   -- T_Or --
371   ----------
372
373   procedure T_Or is
374   begin
375      Check_Token (Tok_Or, AP);
376   end T_Or;
377
378   ---------------
379   -- T_Private --
380   ---------------
381
382   procedure T_Private is
383   begin
384      Check_Token (Tok_Private, SC);
385   end T_Private;
386
387   -------------
388   -- T_Range --
389   -------------
390
391   procedure T_Range is
392   begin
393      Check_Token (Tok_Range, AP);
394   end T_Range;
395
396   --------------
397   -- T_Record --
398   --------------
399
400   procedure T_Record is
401   begin
402      Check_Token (Tok_Record, AP);
403   end T_Record;
404
405   -------------------
406   -- T_Right_Paren --
407   -------------------
408
409   procedure T_Right_Paren is
410   begin
411      if Token = Tok_Right_Paren then
412         Scan;
413      else
414         Error_Msg_AP -- CODEFIX
415           ("|missing "")""");
416      end if;
417   end T_Right_Paren;
418
419   -----------------
420   -- T_Semicolon --
421   -----------------
422
423   procedure T_Semicolon is
424   begin
425
426      if Token = Tok_Semicolon then
427         Scan;
428
429         if Token = Tok_Semicolon then
430            Error_Msg_SC -- CODEFIX
431              ("|extra "";"" ignored");
432            Scan;
433         end if;
434
435         return;
436
437      elsif Token = Tok_Colon then
438         Error_Msg_SC -- CODEFIX
439           ("|"":"" should be "";""");
440         Scan;
441         return;
442
443      elsif Token = Tok_Comma then
444         Error_Msg_SC -- CODEFIX
445           ("|"","" should be "";""");
446         Scan;
447         return;
448
449      elsif Token = Tok_Dot then
450         Error_Msg_SC -- CODEFIX
451           ("|""."" should be "";""");
452         Scan;
453         return;
454
455      --  An interesting little case. If the previous token is a semicolon,
456      --  then there is no way that we can legitimately need another semicolon.
457      --  This could only arise in an situation where an error has already been
458      --  signalled. By simply ignoring the request for a semicolon in this
459      --  case, we avoid some spurious missing semicolon messages.
460
461      elsif Prev_Token = Tok_Semicolon then
462         return;
463
464      --  If the current token is | then this is a reasonable place to suggest
465      --  the possibility of a "C" confusion.
466
467      elsif Token = Tok_Vertical_Bar then
468         Error_Msg_SC -- CODEFIX
469           ("unexpected occurrence of ""'|"", did you mean OR'?");
470         Resync_Past_Semicolon;
471         return;
472
473      --  Deal with pragma. If pragma is not at start of line, it is considered
474      --  misplaced otherwise we treat it as a normal missing semicolon case.
475
476      elsif Token = Tok_Pragma and then not Token_Is_At_Start_Of_Line then
477         P_Pragmas_Misplaced;
478
479         if Token = Tok_Semicolon then
480            Scan;
481            return;
482         end if;
483      end if;
484
485      --  If none of those tests return, we really have a missing semicolon
486
487      Error_Msg_AP -- CODEFIX
488        ("|missing "";""");
489      return;
490   end T_Semicolon;
491
492   ------------
493   -- T_Then --
494   ------------
495
496   procedure T_Then is
497   begin
498      Check_Token (Tok_Then, AP);
499   end T_Then;
500
501   ------------
502   -- T_Type --
503   ------------
504
505   procedure T_Type is
506   begin
507      Check_Token (Tok_Type, BC);
508   end T_Type;
509
510   -----------
511   -- T_Use --
512   -----------
513
514   procedure T_Use is
515   begin
516      Check_Token (Tok_Use, SC);
517   end T_Use;
518
519   ------------
520   -- T_When --
521   ------------
522
523   procedure T_When is
524   begin
525      Check_Token (Tok_When, SC);
526   end T_When;
527
528   ------------
529   -- T_With --
530   ------------
531
532   procedure T_With is
533   begin
534      Check_Token (Tok_With, BC);
535   end T_With;
536
537   --------------
538   -- TF_Arrow --
539   --------------
540
541   procedure TF_Arrow is
542      Scan_State : Saved_Scan_State;
543
544   begin
545      if Token = Tok_Arrow then
546         Scan; -- skip arrow and we are done
547
548      elsif Token = Tok_Colon_Equal then
549         T_Arrow; -- Let T_Arrow give the message
550
551      else
552         T_Arrow; -- give missing arrow message
553         Save_Scan_State (Scan_State); -- at start of junk tokens
554
555         loop
556            if Prev_Token_Ptr < Current_Line_Start
557              or else Token = Tok_Semicolon
558              or else Token = Tok_EOF
559            then
560               Restore_Scan_State (Scan_State); -- to where we were
561               return;
562            end if;
563
564            Scan; -- continue search
565
566            if Token = Tok_Arrow then
567               Scan; -- past arrow
568               return;
569            end if;
570         end loop;
571      end if;
572   end TF_Arrow;
573
574   -----------
575   -- TF_Is --
576   -----------
577
578   procedure TF_Is is
579      Scan_State : Saved_Scan_State;
580
581   begin
582      if Token = Tok_Is then
583         T_Is; -- past IS and we are done
584
585      --  Allow OF or => or = in place of IS (with error message)
586
587      elsif Token = Tok_Of
588        or else Token = Tok_Arrow
589        or else Token = Tok_Equal
590      then
591         T_Is; -- give missing IS message and skip bad token
592
593      else
594         T_Is; -- give missing IS message
595         Save_Scan_State (Scan_State); -- at start of junk tokens
596
597         loop
598            if Prev_Token_Ptr < Current_Line_Start
599              or else Token = Tok_Semicolon
600              or else Token = Tok_EOF
601            then
602               Restore_Scan_State (Scan_State); -- to where we were
603               return;
604            end if;
605
606            Scan; -- continue search
607
608            if Token = Tok_Is
609              or else Token = Tok_Of
610              or else Token = Tok_Arrow
611            then
612               Scan; -- past IS or OF or =>
613               return;
614            end if;
615         end loop;
616      end if;
617   end TF_Is;
618
619   -------------
620   -- TF_Loop --
621   -------------
622
623   procedure TF_Loop is
624      Scan_State : Saved_Scan_State;
625
626   begin
627      if Token = Tok_Loop then
628         Scan; -- past LOOP and we are done
629
630      --  Allow DO or THEN in place of LOOP
631
632      elsif Token = Tok_Then or else Token = Tok_Do then
633         T_Loop; -- give missing LOOP message
634
635      else
636         T_Loop; -- give missing LOOP message
637         Save_Scan_State (Scan_State); -- at start of junk tokens
638
639         loop
640            if Prev_Token_Ptr < Current_Line_Start
641              or else Token = Tok_Semicolon
642              or else Token = Tok_EOF
643            then
644               Restore_Scan_State (Scan_State); -- to where we were
645               return;
646            end if;
647
648            Scan; -- continue search
649
650            if Token = Tok_Loop or else Token = Tok_Then then
651               Scan; -- past loop or then (message already generated)
652               return;
653            end if;
654         end loop;
655      end if;
656   end TF_Loop;
657
658   --------------
659   -- TF_Return--
660   --------------
661
662   procedure TF_Return is
663      Scan_State : Saved_Scan_State;
664
665   begin
666      if Token = Tok_Return then
667         Scan; -- skip RETURN and we are done
668
669      else
670         Error_Msg_SC -- CODEFIX
671           ("missing RETURN");
672         Save_Scan_State (Scan_State); -- at start of junk tokens
673
674         loop
675            if Prev_Token_Ptr < Current_Line_Start
676              or else Token = Tok_Semicolon
677              or else Token = Tok_EOF
678            then
679               Restore_Scan_State (Scan_State); -- to where we were
680               return;
681            end if;
682
683            Scan; -- continue search
684
685            if Token = Tok_Return then
686               Scan; -- past RETURN
687               return;
688            end if;
689         end loop;
690      end if;
691   end TF_Return;
692
693   ------------------
694   -- TF_Semicolon --
695   ------------------
696
697   procedure TF_Semicolon is
698      Scan_State : Saved_Scan_State;
699
700   begin
701      if Token = Tok_Semicolon then
702         T_Semicolon;
703         return;
704
705      --  An interesting little test here. If the previous token is a
706      --  semicolon, then there is no way that we can legitimately need
707      --  another semicolon. This could only arise in an error situation
708      --  where an error has already been signalled. By simply ignoring
709      --  the request for a semicolon in this case, we avoid some spurious
710      --  missing semicolon messages.
711
712      elsif Prev_Token = Tok_Semicolon then
713         return;
714
715      else
716         --  Deal with pragma. If pragma is not at start of line, it is
717         --  considered misplaced otherwise we treat it as a normal
718         --  missing semicolon case.
719
720         if Token = Tok_Pragma
721           and then not Token_Is_At_Start_Of_Line
722         then
723            P_Pragmas_Misplaced;
724
725            if Token = Tok_Semicolon then
726               T_Semicolon;
727               return;
728            end if;
729         end if;
730
731         --  Here we definitely have a missing semicolon, so give message
732
733         T_Semicolon;
734
735         --  Scan out junk on rest of line. Scan stops on END keyword, since
736         --  that seems to help avoid cascaded errors.
737
738         Save_Scan_State (Scan_State); -- at start of junk tokens
739
740         loop
741            if Prev_Token_Ptr < Current_Line_Start
742              or else Token = Tok_EOF
743              or else Token = Tok_End
744            then
745               Restore_Scan_State (Scan_State); -- to where we were
746               return;
747            end if;
748
749            Scan; -- continue search
750
751            if Token = Tok_Semicolon then
752               T_Semicolon;
753               return;
754
755            elsif Token in Token_Class_After_SM then
756               return;
757            end if;
758         end loop;
759      end if;
760   end TF_Semicolon;
761
762   -------------
763   -- TF_Then --
764   -------------
765
766   procedure TF_Then is
767      Scan_State : Saved_Scan_State;
768
769   begin
770      if Token = Tok_Then then
771         Scan; -- past THEN and we are done
772
773      else
774         T_Then; -- give missing THEN message
775         Save_Scan_State (Scan_State); -- at start of junk tokens
776
777         loop
778            if Prev_Token_Ptr < Current_Line_Start
779              or else Token = Tok_Semicolon
780              or else Token = Tok_EOF
781            then
782               Restore_Scan_State (Scan_State); -- to where we were
783               return;
784            end if;
785
786            Scan; -- continue search
787
788            if Token = Tok_Then then
789               Scan; -- past THEN
790               return;
791            end if;
792         end loop;
793      end if;
794   end TF_Then;
795
796   ------------
797   -- TF_Use --
798   ------------
799
800   procedure TF_Use is
801      Scan_State : Saved_Scan_State;
802
803   begin
804      if Token = Tok_Use then
805         Scan; -- past USE and we are done
806
807      else
808         T_Use; -- give USE expected message
809         Save_Scan_State (Scan_State); -- at start of junk tokens
810
811         loop
812            if Prev_Token_Ptr < Current_Line_Start
813              or else Token = Tok_Semicolon
814              or else Token = Tok_EOF
815            then
816               Restore_Scan_State (Scan_State); -- to where we were
817               return;
818            end if;
819
820            Scan; -- continue search
821
822            if Token = Tok_Use then
823               Scan; -- past use
824               return;
825            end if;
826         end loop;
827      end if;
828   end TF_Use;
829
830   ------------------
831   -- U_Left_Paren --
832   ------------------
833
834   procedure U_Left_Paren is
835   begin
836      if Token = Tok_Left_Paren then
837         Scan;
838      else
839         Error_Msg_AP -- CODEFIX
840           ("missing ""(""!");
841      end if;
842   end U_Left_Paren;
843
844   -------------------
845   -- U_Right_Paren --
846   -------------------
847
848   procedure U_Right_Paren is
849   begin
850      if Token = Tok_Right_Paren then
851         Scan;
852      else
853         Error_Msg_AP -- CODEFIX
854           ("|missing "")""!");
855      end if;
856   end U_Right_Paren;
857
858   -----------------
859   -- Wrong_Token --
860   -----------------
861
862   procedure Wrong_Token (T : Token_Type; P : Position) is
863      Missing  : constant String := "missing ";
864      Image    : constant String := Token_Type'Image (T);
865      Tok_Name : constant String := Image (5 .. Image'Length);
866      M        : constant String := Missing & Tok_Name;
867
868   begin
869      if Token = Tok_Semicolon then
870         Scan;
871
872         if Token = T then
873            Error_Msg_SP -- CODEFIX
874              ("|extra "";"" ignored");
875            Scan;
876         else
877            Error_Msg_SP (M);
878         end if;
879
880      elsif Token = Tok_Comma then
881         Scan;
882
883         if Token = T then
884            Error_Msg_SP -- CODEFIX
885              ("|extra "","" ignored");
886            Scan;
887
888         else
889            Error_Msg_SP (M);
890         end if;
891
892      else
893         case P is
894            when SC => Error_Msg_SC (M);
895            when BC => Error_Msg_BC (M);
896            when AP => Error_Msg_AP (M);
897         end case;
898      end if;
899   end Wrong_Token;
900
901end Tchk;
902