Subversion Repositories openrisc_me

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E R R U T I L                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1991-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.      --

--                                                                          --

------------------------------------------------------------------------------

with Err_Vars; use Err_Vars;

with Erroutc;  use Erroutc;

with Namet;    use Namet;

with Opt;      use Opt;

with Output;   use Output;

with Scans;    use Scans;

with Sinput;   use Sinput;

with Stylesw;  use Stylesw;

package body Errutil is

   Errors_Must_Be_Ignored : Boolean := False;

   --  Set to True by procedure Set_Ignore_Errors (True), when calls to

   --  error message procedures should be ignored (when parsing irrelevant

   --  text in sources being preprocessed).

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Error_Msg_AP (Msg : String);

   --  Output a message just after the previous token

   procedure Output_Source_Line

     (L           : Physical_Line_Number;

      Sfile       : Source_File_Index;

      Errs        : Boolean;

      Source_Type : String);

   --  Outputs text of source line L, in file S, together with preceding line

   --  number, as described above for Output_Line_Number. The Errs parameter

   --  indicates if there are errors attached to the line, which forces

   --  listing on, even in the presence of pragma List (Off).

   procedure Set_Msg_Insertion_Column;

   --  Handle column number insertion (@ insertion character)

   procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);

   --  Add a sequence of characters to the current message. The characters may

   --  be one of the special insertion characters (see documentation in spec).

   --  Flag is the location at which the error is to be posted, which is used

   --  to determine whether or not the # insertion needs a file name. The

   --  variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and

   --  Is_Unconditional_Msg are set on return.

   ------------------

   -- Error_Msg_AP --

   ------------------

   procedure Error_Msg_AP (Msg : String) is

      S1 : Source_Ptr;

      C  : Character;

   begin

      --  If we had saved the Scan_Ptr value after scanning the previous

      --  token, then we would have exactly the right place for putting

      --  the flag immediately at hand. However, that would add at least

      --  two instructions to a Scan call *just* to service the possibility

      --  of an Error_Msg_AP call. So instead we reconstruct that value.

      --  We have two possibilities, start with Prev_Token_Ptr and skip over

      --  the current token, which is made harder by the possibility that this

      --  token may be in error, or start with Token_Ptr and work backwards.

      --  We used to take the second approach, but it's hard because of

      --  comments, and harder still because things that look like comments

      --  can appear inside strings. So now we take the first approach.

      --  Note: in the case where there is no previous token, Prev_Token_Ptr

      --  is set to Source_First, which is a reasonable position for the

      --  error flag in this situation.

      S1 := Prev_Token_Ptr;

      C := Source (S1);

      --  If the previous token is a string literal, we need a special approach

      --  since there may be white space inside the literal and we don't want

      --  to stop on that white space.

      --  Note that it is not worth worrying about special UTF_32 line

      --  terminator characters in this context, since this is only about

      --  error recovery anyway.

      if Prev_Token = Tok_String_Literal then

         loop

            S1 := S1 + 1;

            if Source (S1) = C then

               S1 := S1 + 1;

               exit when Source (S1) /= C;

            elsif Source (S1) in Line_Terminator then

               exit;

            end if;

         end loop;

      --  Character literal also needs special handling

      elsif Prev_Token = Tok_Char_Literal then

         S1 := S1 + 3;

      --  Otherwise we search forward for the end of the current token, marked

      --  by a line terminator, white space, a comment symbol or if we bump

      --  into the following token (i.e. the current token)

      --  Note that it is not worth worrying about special UTF_32 line

      --  terminator characters in this context, since this is only about

      --  error recovery anyway.

      else

         while Source (S1) not in Line_Terminator

           and then Source (S1) /= ' '

           and then Source (S1) /= ASCII.HT

           and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')

           and then S1 /= Token_Ptr

         loop

            S1 := S1 + 1;

         end loop;

      end if;

      --  S1 is now set to the location for the flag

      Error_Msg (Msg, S1);

   end Error_Msg_AP;

   ---------------

   -- Error_Msg --

   ---------------

   procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is

      Next_Msg : Error_Msg_Id;

      --  Pointer to next message at insertion point

      Prev_Msg : Error_Msg_Id;

      --  Pointer to previous message at insertion point

      Sptr : Source_Ptr renames Flag_Location;

      --  Corresponds to the Sptr value in the error message object

      Optr : Source_Ptr renames Flag_Location;

      --  Corresponds to the Optr value in the error message object. Note

      --  that for this usage, Sptr and Optr always have the same value,

      --  since we do not have to worry about generic instantiations.

   begin

      if Errors_Must_Be_Ignored then

         return;

      end if;

      if Raise_Exception_On_Error /= 0 then

         raise Error_Msg_Exception;

      end if;

      Test_Style_Warning_Serious_Msg (Msg);

      Set_Msg_Text (Msg, Sptr);

      --  Kill continuation if parent message killed

      if Continuation and Last_Killed then

         return;

      end if;

      --  Return without doing anything if message is killed and this is not

      --  the first error message. The philosophy is that if we get a weird

      --  error message and we already have had a message, then we hope the

      --  weird message is a junk cascaded message

      --  Immediate return if warning message and warnings are suppressed.

      --  Note that style messages are not warnings for this purpose.

      if Is_Warning_Msg and then Warnings_Suppressed (Sptr) then

         Cur_Msg := No_Error_Msg;

         return;

      end if;

      --  Otherwise build error message object for new message

      Errors.Increment_Last;

      Cur_Msg := Errors.Last;

      Errors.Table (Cur_Msg).Text     := new String'(Msg_Buffer (1 .. Msglen));

      Errors.Table (Cur_Msg).Next     := No_Error_Msg;

      Errors.Table (Cur_Msg).Sptr     := Sptr;

      Errors.Table (Cur_Msg).Optr     := Optr;

      Errors.Table (Cur_Msg).Sfile    := Get_Source_File_Index (Sptr);

      Errors.Table (Cur_Msg).Line     := Get_Physical_Line_Number (Sptr);

      Errors.Table (Cur_Msg).Col      := Get_Column_Number (Sptr);

      Errors.Table (Cur_Msg).Style    := Is_Style_Msg;

      Errors.Table (Cur_Msg).Warn     := Is_Warning_Msg;

      Errors.Table (Cur_Msg).Serious  := Is_Serious_Error;

      Errors.Table (Cur_Msg).Uncond   := Is_Unconditional_Msg;

      Errors.Table (Cur_Msg).Msg_Cont := Continuation;

      Errors.Table (Cur_Msg).Deleted  := False;

      Prev_Msg := No_Error_Msg;

      Next_Msg := First_Error_Msg;

      while Next_Msg /= No_Error_Msg loop

         exit when

           Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;

         if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then

            exit when Sptr < Errors.Table (Next_Msg).Sptr;

         end if;

         Prev_Msg := Next_Msg;

         Next_Msg := Errors.Table (Next_Msg).Next;

      end loop;

      --  Now we insert the new message in the error chain. The insertion

      --  point for the message is after Prev_Msg and before Next_Msg.

      --  The possible insertion point for the new message is after Prev_Msg

      --  and before Next_Msg. However, this is where we do a special check

      --  for redundant parsing messages, defined as messages posted on the

      --  same line. The idea here is that probably such messages are junk

      --  from the parser recovering. In full errors mode, we don't do this

      --  deletion, but otherwise such messages are discarded at this stage.

      if Prev_Msg /= No_Error_Msg

        and then Errors.Table (Prev_Msg).Line =

        Errors.Table (Cur_Msg).Line

        and then Errors.Table (Prev_Msg).Sfile =

        Errors.Table (Cur_Msg).Sfile

      then

         --  Don't delete unconditional messages and at this stage, don't

         --  delete continuation lines (we attempted to delete those earlier

         --  if the parent message was deleted.

         if not Errors.Table (Cur_Msg).Uncond

           and then not Continuation

         then

            --  Don't delete if prev msg is warning and new msg is an error.

            --  This is because we don't want a real error masked by a warning.

            --  In all other cases (that is parse errors for the same line that

            --  are not unconditional) we do delete the message. This helps to

            --  avoid junk extra messages from cascaded parsing errors

            if not (Errors.Table (Prev_Msg).Warn

                     or else

                    Errors.Table (Prev_Msg).Style)

              or else

                   (Errors.Table (Cur_Msg).Warn

                     or else

                    Errors.Table (Cur_Msg).Style)

            then

               --  All tests passed, delete the message by simply returning

               --  without any further processing.

               if not Continuation then

                  Last_Killed := True;

               end if;

               return;

            end if;

         end if;

      end if;

      --  Come here if message is to be inserted in the error chain

      if not Continuation then

         Last_Killed := False;

      end if;

      if Prev_Msg = No_Error_Msg then

         First_Error_Msg := Cur_Msg;

      else

         Errors.Table (Prev_Msg).Next := Cur_Msg;

      end if;

      Errors.Table (Cur_Msg).Next := Next_Msg;

      --  Bump appropriate statistics count

      if Errors.Table (Cur_Msg).Warn

           or else

         Errors.Table (Cur_Msg).Style

      then

         Warnings_Detected := Warnings_Detected + 1;

      else

         Total_Errors_Detected := Total_Errors_Detected + 1;

         if Errors.Table (Cur_Msg).Serious then

            Serious_Errors_Detected := Serious_Errors_Detected + 1;

         end if;

      end if;

   end Error_Msg;

   -----------------

   -- Error_Msg_S --

   -----------------

   procedure Error_Msg_S (Msg : String) is

   begin

      Error_Msg (Msg, Scan_Ptr);

   end Error_Msg_S;

   ------------------

   -- Error_Msg_SC --

   ------------------

   procedure Error_Msg_SC (Msg : String) is

   begin

      --  If we are at end of file, post the flag after the previous token

      if Token = Tok_EOF then

         Error_Msg_AP (Msg);

      --  For all other cases the message is posted at the current token

      --  pointer position

      else

         Error_Msg (Msg, Token_Ptr);

      end if;

   end Error_Msg_SC;

   ------------------

   -- Error_Msg_SP --

   ------------------

   procedure Error_Msg_SP (Msg : String) is

   begin

      --  Note: in the case where there is no previous token, Prev_Token_Ptr

      --  is set to Source_First, which is a reasonable position for the

      --  error flag in this situation

      Error_Msg (Msg, Prev_Token_Ptr);

   end Error_Msg_SP;

   --------------

   -- Finalize --

   --------------

   procedure Finalize (Source_Type : String := "project") is

      Cur      : Error_Msg_Id;

      Nxt      : Error_Msg_Id;

      E, F     : Error_Msg_Id;

      Err_Flag : Boolean;

   begin

      --  Eliminate any duplicated error messages from the list. This is

      --  done after the fact to avoid problems with Change_Error_Text.

      Cur := First_Error_Msg;

      while Cur /= No_Error_Msg loop

         Nxt := Errors.Table (Cur).Next;

         F := Nxt;

         while F /= No_Error_Msg

           and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr

         loop

            Check_Duplicate_Message (Cur, F);

            F := Errors.Table (F).Next;

         end loop;

         Cur := Nxt;

      end loop;

      --  Brief Error mode

      if Brief_Output or (not Full_List and not Verbose_Mode) then

         E := First_Error_Msg;

         Set_Standard_Error;

         while E /= No_Error_Msg loop

            if not Errors.Table (E).Deleted then

               if Full_Path_Name_For_Brief_Errors then

                  Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));

               else

                  Write_Name (Reference_Name (Errors.Table (E).Sfile));

               end if;

               Write_Char (':');

               Write_Int (Int (Physical_To_Logical

                                (Errors.Table (E).Line,

                                 Errors.Table (E).Sfile)));

               Write_Char (':');

               if Errors.Table (E).Col < 10 then

                  Write_Char ('0');

               end if;

               Write_Int (Int (Errors.Table (E).Col));

               Write_Str (": ");

               Output_Msg_Text (E);

               Write_Eol;

            end if;

            E := Errors.Table (E).Next;

         end loop;

         Set_Standard_Output;

      end if;

      --  Full source listing case

      if Full_List then

         List_Pragmas_Index := 1;

         List_Pragmas_Mode := True;

         E := First_Error_Msg;

         Write_Eol;

         --  First list initial main source file with its error messages

         for N in 1 .. Last_Source_Line (Main_Source_File) loop

            Err_Flag :=

              E /= No_Error_Msg

                and then Errors.Table (E).Line = N

                and then Errors.Table (E).Sfile = Main_Source_File;

            Output_Source_Line (N, Main_Source_File, Err_Flag, Source_Type);

            if Err_Flag then

               Output_Error_Msgs (E);

               Write_Eol;

            end if;

         end loop;

         --  Then output errors, if any, for subsidiary units

         while E /= No_Error_Msg

           and then Errors.Table (E).Sfile /= Main_Source_File

         loop

            Write_Eol;

            Output_Source_Line

              (Errors.Table (E).Line,

               Errors.Table (E).Sfile,

               True,

               Source_Type);

            Output_Error_Msgs (E);

         end loop;

      end if;

      --  Verbose mode (error lines only with error flags)

      if Verbose_Mode then

         E := First_Error_Msg;

         --  Loop through error lines

         while E /= No_Error_Msg loop

            Write_Eol;

            Output_Source_Line

              (Errors.Table (E).Line,

               Errors.Table (E).Sfile,

               True,

               Source_Type);

            Output_Error_Msgs (E);

         end loop;

      end if;

      --  Output error summary if verbose or full list mode

      if Verbose_Mode or else Full_List then

         --  Extra blank line if error messages or source listing were output

         if Total_Errors_Detected + Warnings_Detected > 0

           or else Full_List

         then

            Write_Eol;

         end if;

         --  Message giving number of lines read and number of errors detected.

         --  This normally goes to Standard_Output. The exception is when brief

         --  mode is not set, verbose mode (or full list mode) is set, and

         --  there are errors. In this case we send the message to standard

         --  error to make sure that *something* appears on standard error in

         --  an error situation.

         --  Formerly, only the "# errors" suffix was sent to stderr, whereas

         --  "# lines:" appeared on stdout. This caused problems on VMS when

         --  the stdout buffer was flushed, giving an extra line feed after

         --  the prefix.

         if Total_Errors_Detected + Warnings_Detected /= 0

           and then not Brief_Output

           and then (Verbose_Mode or Full_List)

         then

            Set_Standard_Error;

         end if;

         --  Message giving total number of lines

         Write_Str (" ");

         Write_Int (Num_Source_Lines (Main_Source_File));

         if Num_Source_Lines (Main_Source_File) = 1 then

            Write_Str (" line: ");

         else

            Write_Str (" lines: ");

         end if;

         if Total_Errors_Detected = 0 then

            Write_Str ("No errors");

         elsif Total_Errors_Detected = 1 then

            Write_Str ("1 error");

         else

            Write_Int (Total_Errors_Detected);

            Write_Str (" errors");

         end if;

         if Warnings_Detected /= 0 then

            Write_Str (", ");

            Write_Int (Warnings_Detected);

            Write_Str (" warning");

            if Warnings_Detected /= 1 then

               Write_Char ('s');

            end if;

            if Warning_Mode = Treat_As_Error then

               Write_Str (" (treated as error");

               if Warnings_Detected /= 1 then

                  Write_Char ('s');

               end if;

               Write_Char (')');

            end if;

         end if;

         Write_Eol;

         Set_Standard_Output;

      end if;

      if Maximum_Messages /= 0 then

         if Warnings_Detected >= Maximum_Messages then

            Set_Standard_Error;

            Write_Line ("maximum number of warnings detected");

            Warning_Mode := Suppress;

         end if;

         if Total_Errors_Detected >= Maximum_Messages then

            Set_Standard_Error;

            Write_Line ("fatal error: maximum errors reached");

            Set_Standard_Output;

         end if;

      end if;

      if Warning_Mode = Treat_As_Error then

         Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;

         Warnings_Detected := 0;

      end if;

   end Finalize;

   ----------------

   -- Initialize --

   ----------------

   procedure Initialize is

   begin

      Errors.Init;

      First_Error_Msg := No_Error_Msg;

      Last_Error_Msg  := No_Error_Msg;

      Serious_Errors_Detected := 0;

      Total_Errors_Detected := 0;

      Warnings_Detected := 0;

      Cur_Msg := No_Error_Msg;

      --  Initialize warnings table, if all warnings are suppressed, supply

      --  an initial dummy entry covering all possible source locations.

      Warnings.Init;

      if Warning_Mode = Suppress then

         Warnings.Increment_Last;

         Warnings.Table (Warnings.Last).Start := Source_Ptr'First;

         Warnings.Table (Warnings.Last).Stop  := Source_Ptr'Last;

      end if;

   end Initialize;

   ------------------------

   -- Output_Source_Line --

   ------------------------

   procedure Output_Source_Line

     (L           : Physical_Line_Number;

      Sfile       : Source_File_Index;

      Errs        : Boolean;

      Source_Type : String)

   is

      S : Source_Ptr;

      C : Character;

      Line_Number_Output : Boolean := False;

      --  Set True once line number is output

   begin

      if Sfile /= Current_Error_Source_File then

         Write_Str ("==============Error messages for ");

         Write_Str (Source_Type);

         Write_Str (" file: ");

         Write_Name (Full_File_Name (Sfile));

         Write_Eol;

         Current_Error_Source_File := Sfile;

      end if;

      if Errs then

         Output_Line_Number (Physical_To_Logical (L, Sfile));

         Line_Number_Output := True;

      end if;

      S := Line_Start (L, Sfile);

      loop

         C := Source_Text (Sfile) (S);

         exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;

         if Errs then

            Write_Char (C);

         end if;

         S := S + 1;

      end loop;

      if Line_Number_Output then

         Write_Eol;

      end if;

   end Output_Source_Line;

   -----------------------

   -- Set_Ignore_Errors --

   -----------------------

   procedure Set_Ignore_Errors (To : Boolean) is

   begin

      Errors_Must_Be_Ignored := To;

   end Set_Ignore_Errors;

   ------------------------------

   -- Set_Msg_Insertion_Column --

   ------------------------------

   procedure Set_Msg_Insertion_Column is

   begin

      if RM_Column_Check then

         Set_Msg_Str (" in column ");

         Set_Msg_Int (Int (Error_Msg_Col) + 1);

      end if;

   end Set_Msg_Insertion_Column;

   ------------------

   -- Set_Msg_Text --

   ------------------

   procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is

      C : Character;         -- Current character

      P : Natural;           -- Current index;

   begin

      Manual_Quote_Mode := False;

      Msglen := 0;

      Flag_Source := Get_Source_File_Index (Flag);

      P := Text'First;

      while P <= Text'Last loop

         C := Text (P);

         P := P + 1;

         --  Check for insertion character

         if C = '%' then

            if P <= Text'Last and then Text (P) = '%' then

               P := P + 1;

               Set_Msg_Insertion_Name_Literal;

            else

               Set_Msg_Insertion_Name;

            end if;

         elsif C = '$' then

            --  '$' is ignored

            null;

         elsif C = '{' then

            Set_Msg_Insertion_File_Name;

         elsif C = '}' then

            --  '}' is ignored

            null;

         elsif C = '*' then

            Set_Msg_Insertion_Reserved_Name;

         elsif C = '&' then

            --  '&' is ignored

            null;

         elsif C = '#' then

            Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);

         elsif C = '\' then

            Continuation := True;

         elsif C = '@' then

            Set_Msg_Insertion_Column;

         elsif C = '^' then

            Set_Msg_Insertion_Uint;

         elsif C = '`' then

            Manual_Quote_Mode := not Manual_Quote_Mode;

            Set_Msg_Char ('"');

         elsif C = '!' then

            Is_Unconditional_Msg := True;

         elsif C = '?' then

            null;

         elsif C = '<' then

            null;

         elsif C = '|' then

            null;

         elsif C = ''' then

            Set_Msg_Char (Text (P));

            P := P + 1;

         --  Upper case letter (start of reserved word if 2 or more)

         elsif C in 'A' .. 'Z'

           and then P <= Text'Last

           and then Text (P) in 'A' .. 'Z'

         then

            P := P - 1;

            Set_Msg_Insertion_Reserved_Word (Text, P);

         --  Normal character with no special treatment

         else

            Set_Msg_Char (C);

         end if;

      end loop;

   end Set_Msg_Text;

end Errutil;