------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E R R U T I L -- -- -- -- B o d y -- -- -- -- Copyright (C) 1991-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. -- -- -- ------------------------------------------------------------------------------ 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. -- 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 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 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;