gcc/gcc/ada/par-tchk.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             P A R . T C H K                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Token scan routines

--  Error recovery: none of the T_xxx or TF_xxx routines raise Error_Resync

separate (Par)
package body Tchk is

   type Position is (SC, BC, AP);
   --  Specify position of error message (see Error_Msg_SC/BC/AP)

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Check_Token (T : Token_Type; P : Position);
   pragma Inline (Check_Token);
   --  Called by T_xx routines to check for reserved keyword token. P is the
   --  position of the error message if the token is missing (see Wrong_Token)

   procedure Wrong_Token (T : Token_Type; P : Position);
   --  Called when scanning a reserved keyword when the keyword is not
   --  present. T is the token type for the keyword, and P indicates the
   --  position to be used to place a message relative to the current
   --  token if the keyword is not located nearby.

   -----------------
   -- Check_Token --
   -----------------

   procedure Check_Token (T : Token_Type; P : Position) is
   begin
      if Token = T then
         Scan;
         return;
      else
         Wrong_Token (T, P);
      end if;
   end Check_Token;

   -------------
   -- T_Abort --
   -------------

   procedure T_Abort is
   begin
      Check_Token (Tok_Abort, SC);
   end T_Abort;

   -------------
   -- T_Arrow --
   -------------

   procedure T_Arrow is
   begin
      if Token = Tok_Arrow then
         Scan;

      --  A little recovery helper, accept then in place of =>

      elsif Token = Tok_Then then
         Error_Msg_BC ("missing ""='>""");
         Scan; -- past THEN used in place of =>

      elsif Token = Tok_Colon_Equal then
         Error_Msg_SC (""":="" should be ""='>""");
         Scan; -- past := used in place of =>

      else
         Error_Msg_AP ("missing ""='>""");
      end if;
   end T_Arrow;

   ----------
   -- T_At --
   ----------

   procedure T_At is
   begin
      Check_Token (Tok_At, SC);
   end T_At;

   ------------
   -- T_Body --
   ------------

   procedure T_Body is
   begin
      Check_Token (Tok_Body, BC);
   end T_Body;

   -----------
   -- T_Box --
   -----------

   procedure T_Box is
   begin
      if Token = Tok_Box then
         Scan;
      else
         Error_Msg_AP ("missing ""'<'>""");
      end if;
   end T_Box;

   -------------
   -- T_Colon --
   -------------

   procedure T_Colon is
   begin
      if Token = Tok_Colon then
         Scan;
      else
         Error_Msg_AP ("missing "":""");
      end if;
   end T_Colon;

   -------------------
   -- T_Colon_Equal --
   -------------------

   procedure T_Colon_Equal is
   begin
      if Token = Tok_Colon_Equal then
         Scan;

      elsif Token = Tok_Equal then
         Error_Msg_SC ("""="" should be "":=""");
         Scan;

      elsif Token = Tok_Colon then
         Error_Msg_SC (""":"" should be "":=""");
         Scan;

      elsif Token = Tok_Is then
         Error_Msg_SC ("IS should be "":=""");
         Scan;

      else
         Error_Msg_AP ("missing "":=""");
      end if;
   end T_Colon_Equal;

   -------------
   -- T_Comma --
   -------------

   procedure T_Comma is
   begin
      if Token = Tok_Comma then
         Scan;

      else
         if Token = Tok_Pragma then
            P_Pragmas_Misplaced;
         end if;

         if Token = Tok_Comma then
            Scan;
         else
            Error_Msg_AP ("missing "",""");
         end if;
      end if;

      if Token = Tok_Pragma then
         P_Pragmas_Misplaced;
      end if;
   end T_Comma;

   ---------------
   -- T_Dot_Dot --
   ---------------

   procedure T_Dot_Dot is
   begin
      if Token = Tok_Dot_Dot then
         Scan;
      else
         Error_Msg_AP ("missing ""..""");
      end if;
   end T_Dot_Dot;

   -----------
   -- T_For --
   -----------

   procedure T_For is
   begin
      Check_Token (Tok_For, AP);
   end T_For;

   -----------------------
   -- T_Greater_Greater --
   -----------------------

   procedure T_Greater_Greater is
   begin
      if Token = Tok_Greater_Greater then
         Scan;
      else
         Error_Msg_AP ("missing ""'>'>""");
      end if;
   end T_Greater_Greater;

   ------------------
   -- T_Identifier --
   ------------------

   procedure T_Identifier is
   begin
      if Token = Tok_Identifier then
         Scan;
      elsif Token in Token_Class_Literal then
         Error_Msg_SC ("identifier expected");
         Scan;
      else
         Error_Msg_AP ("identifier expected");
      end if;
   end T_Identifier;

   ----------
   -- T_In --
   ----------

   procedure T_In is
   begin
      Check_Token (Tok_In, AP);
   end T_In;

   ----------
   -- T_Is --
   ----------

   procedure T_Is is
   begin
      if Token = Tok_Is then
         Scan;

         Ignore (Tok_Semicolon);

      --  Allow OF, => or = to substitute for IS with complaint

      elsif Token = Tok_Arrow
        or else Token = Tok_Of
        or else Token = Tok_Equal
      then
         Error_Msg_SC ("missing IS");
         Scan; -- token used in place of IS
      else
         Wrong_Token (Tok_Is, AP);
      end if;

      while Token = Tok_Is loop
         Error_Msg_SC ("extra IS ignored");
         Scan;
      end loop;
   end T_Is;

   ------------------
   -- T_Left_Paren --
   ------------------

   procedure T_Left_Paren is
   begin
      if Token = Tok_Left_Paren then
         Scan;
      else
         Error_Msg_AP ("missing ""(""");
      end if;
   end T_Left_Paren;

   ------------
   -- T_Loop --
   ------------

   procedure T_Loop is
   begin
      if Token = Tok_Do then
         Error_Msg_SC ("LOOP expected");
         Scan;
      else
         Check_Token (Tok_Loop, AP);
      end if;
   end T_Loop;

   -----------
   -- T_Mod --
   -----------

   procedure T_Mod is
   begin
      Check_Token (Tok_Mod, AP);
   end T_Mod;

   -----------
   -- T_New --
   -----------

   procedure T_New is
   begin
      Check_Token (Tok_New, AP);
   end T_New;

   ----------
   -- T_Of --
   ----------

   procedure T_Of is
   begin
      Check_Token (Tok_Of, AP);
   end T_Of;

   ----------
   -- T_Or --
   ----------

   procedure T_Or is
   begin
      Check_Token (Tok_Or, AP);
   end T_Or;

   ---------------
   -- T_Private --
   ---------------

   procedure T_Private is
   begin
      Check_Token (Tok_Private, SC);
   end T_Private;

   -------------
   -- T_Range --
   -------------

   procedure T_Range is
   begin
      Check_Token (Tok_Range, AP);
   end T_Range;

   --------------
   -- T_Record --
   --------------

   procedure T_Record is
   begin
      Check_Token (Tok_Record, AP);
   end T_Record;

   -------------------
   -- T_Right_Paren --
   -------------------

   procedure T_Right_Paren is
   begin
      if Token = Tok_Right_Paren then
         Scan;
      else
         Error_Msg_AP ("missing "")""");
      end if;
   end T_Right_Paren;

   -----------------
   -- T_Semicolon --
   -----------------

   procedure T_Semicolon is
   begin

      if Token = Tok_Semicolon then
         Scan;

         if Token = Tok_Semicolon then
            Error_Msg_SC ("extra "";"" ignored");
            Scan;
         end if;

         return;

      elsif Token = Tok_Colon then
         Error_Msg_SC (""":"" should be "";""");
         Scan;
         return;

      elsif Token = Tok_Comma then
         Error_Msg_SC (""","" should be "";""");
         Scan;
         return;

      elsif Token = Tok_Dot then
         Error_Msg_SC ("""."" should be "";""");
         Scan;
         return;

      --  An interesting little kludge here. If the previous token is a
      --  semicolon, then there is no way that we can legitimately need
      --  another semicolon. This could only arise in an error situation
      --  where an error has already been signalled. By simply ignoring
      --  the request for a semicolon in this case, we avoid some spurious
      --  missing semicolon messages.

      elsif Prev_Token = Tok_Semicolon then
         return;

      --  If the current token is | then this is a reasonable
      --  place to suggest the possibility of a "C" confusion :-)

      elsif Token = Tok_Vertical_Bar then
         Error_Msg_SC ("unexpected occurrence of ""'|"", did you mean OR'?");
         Resync_Past_Semicolon;
         return;

      --  Deal with pragma. If pragma is not at start of line, it is
      --  considered misplaced otherwise we treat it as a normal
      --  missing semicolong case.

      elsif Token = Tok_Pragma
        and then not Token_Is_At_Start_Of_Line
      then
         P_Pragmas_Misplaced;

         if Token = Tok_Semicolon then
            Scan;
            return;
         end if;
      end if;

      --  If none of those tests return, we really have a missing semicolon

      Error_Msg_AP ("|missing "";""");
      return;
   end T_Semicolon;

   ------------
   -- T_Then --
   ------------

   procedure T_Then is
   begin
      Check_Token (Tok_Then, AP);
   end T_Then;

   ------------
   -- T_Type --
   ------------

   procedure T_Type is
   begin
      Check_Token (Tok_Type, BC);
   end T_Type;

   -----------
   -- T_Use --
   -----------

   procedure T_Use is
   begin
      Check_Token (Tok_Use, SC);
   end T_Use;

   ------------
   -- T_When --
   ------------

   procedure T_When is
   begin
      Check_Token (Tok_When, SC);
   end T_When;

   ------------
   -- T_With --
   ------------

   procedure T_With is
   begin
      Check_Token (Tok_With, BC);
   end T_With;

   --------------
   -- TF_Arrow --
   --------------

   procedure TF_Arrow is
      Scan_State : Saved_Scan_State;

   begin
      if Token = Tok_Arrow then
         Scan; -- skip arrow and we are done

      elsif Token = Tok_Colon_Equal then
         T_Arrow; -- Let T_Arrow give the message

      else
         T_Arrow; -- give missing arrow message
         Save_Scan_State (Scan_State); -- at start of junk tokens

         loop
            if Prev_Token_Ptr < Current_Line_Start
              or else Token = Tok_Semicolon
              or else Token = Tok_EOF
            then
               Restore_Scan_State (Scan_State); -- to where we were!
               return;
            end if;

            Scan; -- continue search!

            if Token = Tok_Arrow then
               Scan; -- past arrow
               return;
            end if;
         end loop;
      end if;
   end TF_Arrow;

   -----------
   -- TF_Is --
   -----------

   procedure TF_Is is
      Scan_State : Saved_Scan_State;

   begin
      if Token = Tok_Is then
         T_Is; -- past IS and we are done

      --  Allow OF or => or = in place of IS (with error message)

      elsif Token = Tok_Of
        or else Token = Tok_Arrow
        or else Token = Tok_Equal
      then
         T_Is; -- give missing IS message and skip bad token

      else
         T_Is; -- give missing IS message
         Save_Scan_State (Scan_State); -- at start of junk tokens

         loop
            if Prev_Token_Ptr < Current_Line_Start
              or else Token = Tok_Semicolon
              or else Token = Tok_EOF
            then
               Restore_Scan_State (Scan_State); -- to where we were!
               return;
            end if;

            Scan; -- continue search!

            if Token = Tok_Is
              or else Token = Tok_Of
              or else Token = Tok_Arrow
            then
               Scan; -- past IS or OF or =>
               return;
            end if;
         end loop;
      end if;
   end TF_Is;

   -------------
   -- TF_Loop --
   -------------

   procedure TF_Loop is
      Scan_State : Saved_Scan_State;

   begin
      if Token = Tok_Loop then
         Scan; -- past LOOP and we are done

      --  Allow DO or THEN in place of LOOP

      elsif Token = Tok_Then or else Token = Tok_Do then
         T_Loop; -- give missing LOOP message

      else
         T_Loop; -- give missing LOOP message
         Save_Scan_State (Scan_State); -- at start of junk tokens

         loop
            if Prev_Token_Ptr < Current_Line_Start
              or else Token = Tok_Semicolon
              or else Token = Tok_EOF
            then
               Restore_Scan_State (Scan_State); -- to where we were!
               return;
            end if;

            Scan; -- continue search!

            if Token = Tok_Loop or else Token = Tok_Then then
               Scan; -- past loop or then (message already generated)
               return;
            end if;
         end loop;
      end if;
   end TF_Loop;

   --------------
   -- TF_Return--
   --------------

   procedure TF_Return is
      Scan_State : Saved_Scan_State;

   begin
      if Token = Tok_Return then
         Scan; -- skip RETURN and we are done

      else
         Error_Msg_SC ("missing RETURN");
         Save_Scan_State (Scan_State); -- at start of junk tokens

         loop
            if Prev_Token_Ptr < Current_Line_Start
              or else Token = Tok_Semicolon
              or else Token = Tok_EOF
            then
               Restore_Scan_State (Scan_State); -- to where we were!
               return;
            end if;

            Scan; -- continue search!

            if Token = Tok_Return then
               Scan; -- past RETURN
               return;
            end if;
         end loop;
      end if;
   end TF_Return;

   ------------------
   -- TF_Semicolon --
   ------------------

   procedure TF_Semicolon is
      Scan_State : Saved_Scan_State;

   begin
      if Token = Tok_Semicolon then
         T_Semicolon;
         return;

      --  An interesting little kludge here. If the previous token is a
      --  semicolon, then there is no way that we can legitimately need
      --  another semicolon. This could only arise in an error situation
      --  where an error has already been signalled. By simply ignoring
      --  the request for a semicolon in this case, we avoid some spurious
      --  missing semicolon messages.

      elsif Prev_Token = Tok_Semicolon then
         return;

      else
         --  Deal with pragma. If pragma is not at start of line, it is
         --  considered misplaced otherwise we treat it as a normal
         --  missing semicolong case.

         if Token = Tok_Pragma
           and then not Token_Is_At_Start_Of_Line
         then
            P_Pragmas_Misplaced;

            if Token = Tok_Semicolon then
               T_Semicolon;
               return;
            end if;
         end if;

         --  Here we definitely have a missing semicolon, so give message

         T_Semicolon;

         --  Scan out junk on rest of line

         Save_Scan_State (Scan_State); -- at start of junk tokens

         loop
            if Prev_Token_Ptr < Current_Line_Start
              or else Token = Tok_EOF
            then
               Restore_Scan_State (Scan_State); -- to where we were
               return;
            end if;

            Scan; -- continue search

            if Token = Tok_Semicolon then
               T_Semicolon;
               return;

            elsif Token in Token_Class_After_SM then
               return;
            end if;
         end loop;
      end if;
   end TF_Semicolon;

   -------------
   -- TF_Then --
   -------------

   procedure TF_Then is
      Scan_State : Saved_Scan_State;

   begin
      if Token = Tok_Then then
         Scan; -- past THEN and we are done

      else
         T_Then; -- give missing THEN message
         Save_Scan_State (Scan_State); -- at start of junk tokens

         loop
            if Prev_Token_Ptr < Current_Line_Start
              or else Token = Tok_Semicolon
              or else Token = Tok_EOF
            then
               Restore_Scan_State (Scan_State); -- to where we were
               return;
            end if;

            Scan; -- continue search!

            if Token = Tok_Then then
               Scan; -- past THEN
               return;
            end if;
         end loop;
      end if;
   end TF_Then;

   ------------
   -- TF_Use --
   ------------

   procedure TF_Use is
      Scan_State : Saved_Scan_State;

   begin
      if Token = Tok_Use then
         Scan; -- past USE and we are done

      else
         T_Use; -- give USE expected message
         Save_Scan_State (Scan_State); -- at start of junk tokens

         loop
            if Prev_Token_Ptr < Current_Line_Start
              or else Token = Tok_Semicolon
              or else Token = Tok_EOF
            then
               Restore_Scan_State (Scan_State); -- to where we were
               return;
            end if;

            Scan; -- continue search!

            if Token = Tok_Use then
               Scan; -- past use
               return;
            end if;
         end loop;
      end if;
   end TF_Use;

   -----------------
   -- Wrong_Token --
   -----------------

   procedure Wrong_Token (T : Token_Type; P : Position) is
      Missing : constant String := "missing ";
      Image : constant String := Token_Type'Image (T);
      Tok_Name : constant String := Image (5 .. Image'Length);
      M : String (1 .. Missing'Length + Tok_Name'Length);

   begin
      --  Set M to Missing & Tok_Name

      M (1 .. Missing'Length) := Missing;
      M (Missing'Length + 1 .. M'Last) := Tok_Name;

      if Token = Tok_Semicolon then
         Scan;

         if Token = T then
            Error_Msg_SP ("extra "";"" ignored");
            Scan;
         else
            Error_Msg_SP (M);
         end if;

      elsif Token = Tok_Comma then
         Scan;

         if Token = T then
            Error_Msg_SP ("extra "","" ignored");
            Scan;

         else
            Error_Msg_SP (M);
         end if;

      else
         case P is
            when SC => Error_Msg_SC (M);
            when BC => Error_Msg_BC (M);
            when AP => Error_Msg_AP (M);
         end case;
      end if;
   end Wrong_Token;

end Tchk;