blob: 855d464add92222cea549fd1c0245ad47081bdb4 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E R R U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-2003 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, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- 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;
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.
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)
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
Errors.Table (Prev_Msg).Style)
or else
(Errors.Table (Cur_Msg).Warn
or
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 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_Errors /= 0
and then Total_Errors_Detected + Warnings_Detected = Maximum_Errors
then
Set_Standard_Error;
Write_Str ("fatal error: maximum errors reached");
Write_Eol;
Set_Standard_Output;
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;
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 Style.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
Set_Msg_Insertion_Name;
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
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;