gcc/ada/errutil.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              E R R U T I L                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1991-2012, 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 Atree;    use Atree;
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).Warn_Chr := Warning_Msg_Char;
      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;

      --  Prevent displaying the same messages again in the future

      First_Error_Msg := No_Error_Msg;
   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;