Subversion Repositories openrisc

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             P A R . T C H K                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2009, 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 3,  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 COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- 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 ("|THEN should be ""='>""");
         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
      Ignore (Tok_Semicolon);
 
      --  If we have IS scan past it
 
      if Token = Tok_Is then
         Scan;
 
         --  And ignore any following semicolons
 
         Ignore (Tok_Semicolon);
 
      --  Allow OF, => or = to substitute for IS with complaint
 
      elsif Token = Tok_Arrow then
         Error_Msg_SC ("|""=>"" should be IS");
         Scan; -- past =>
 
      elsif Token = Tok_Of then
         Error_Msg_SC ("|OF should be IS");
         Scan; -- past OF
 
      elsif Token = Tok_Equal then
         Error_Msg_SC ("|""="" should be IS");
         Scan; -- past =
 
      else
         Wrong_Token (Tok_Is, AP);
      end if;
 
      --  Ignore extra IS keywords
 
      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 -- CODEFIX
           ("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 semicolon 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 semicolon 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. Scan stops on END keyword, since
         --  that seems to help avoid cascaded errors.
 
         Save_Scan_State (Scan_State); -- at start of junk tokens
 
         loop
            if Prev_Token_Ptr < Current_Line_Start
              or else Token = Tok_EOF
              or else Token = Tok_End
            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;
 
   ------------------
   -- U_Left_Paren --
   ------------------
 
   procedure U_Left_Paren is
   begin
      if Token = Tok_Left_Paren then
         Scan;
      else
         Error_Msg_AP ("missing ""(""!");
      end if;
   end U_Left_Paren;
 
   -------------------
   -- U_Right_Paren --
   -------------------
 
   procedure U_Right_Paren is
   begin
      if Token = Tok_Right_Paren then
         Scan;
      else
         Error_Msg_AP ("|missing "")""!");
      end if;
   end U_Right_Paren;
 
   -----------------
   -- 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        : constant String := Missing & Tok_Name;
 
   begin
      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;