From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/errutil.adb | 774 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 774 insertions(+) create mode 100644 gcc/ada/errutil.adb (limited to 'gcc/ada/errutil.adb') diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb new file mode 100644 index 000000000..6a5bb692d --- /dev/null +++ b/gcc/ada/errutil.adb @@ -0,0 +1,774 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; -- cgit v1.2.3