-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- 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. --
+-- 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. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by AdaCore. --
-- --
------------------------------------------------------------------------------
--------------------
procedure Compiler_Abort
- (X : String;
- Code : Integer := 0)
+ (X : String;
+ Code : Integer := 0;
+ Fallback_Loc : String := "")
is
+ -- The procedures below output a "bug box" with information about
+ -- the cause of the compiler abort and about the preferred method
+ -- of reporting bugs. The default is a bug box appropriate for
+ -- the FSF version of GNAT, but there are specializations for
+ -- the GNATPRO and Public releases by AdaCore.
+
+ XF : constant Positive := X'First;
+ -- Start index, usually 1, but we won't assume this
+
procedure End_Line;
-- Add blanks up to column 76, and then a final vertical bar
+ --------------
+ -- End_Line --
+ --------------
+
procedure End_Line is
begin
Repeat_Char (' ', 76, '|');
Write_Eol;
end End_Line;
- Public_Version : constant Boolean := (Gnat_Version_String (5) = 'p');
+ Is_GPL_Version : constant Boolean := Gnatvsn.Build_Type = GPL;
+ Is_FSF_Version : constant Boolean := Gnatvsn.Build_Type = FSF;
-- Start of processing for Compiler_Abort
begin
- -- Prevent recursion through Compiler_Abort, e.g. via SIGSEGV.
+ Cancel_Special_Output;
+
+ -- Prevent recursion through Compiler_Abort, e.g. via SIGSEGV
if Abort_In_Progress then
Exit_Program (E_Abort);
Abort_In_Progress := True;
- -- If errors have already occured, then we guess that the abort may
- -- well be caused by previous errors, and we don't make too much fuss
- -- about it, since we want to let the programmer fix the errors first.
+ -- If any errors have already occurred, then we guess that the abort
+ -- may well be caused by previous errors, and we don't make too much
+ -- fuss about it, since we want to let programmer fix the errors first.
-- Debug flag K disables this behavior (useful for debugging)
- if Errors_Detected /= 0 and then not Debug_Flag_K then
+ if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then
Errout.Finalize;
+ Errout.Output_Messages;
Set_Standard_Error;
Write_Str ("compilation abandoned due to previous error");
Last_Blank : Integer := 70;
begin
- for P in 40 .. 69 loop
- if X (P) = ' ' then
+ for P in 39 .. 68 loop
+ if X (XF + P) = ' ' then
Last_Blank := P;
end if;
end loop;
- Write_Str (X (1 .. Last_Blank));
+ Write_Str (X (XF .. XF - 1 + Last_Blank));
End_Line;
Write_Str ("| ");
- Write_Str (X (Last_Blank + 1 .. X'Length));
+ Write_Str (X (XF + Last_Blank .. X'Last));
end;
else
Write_Str (X);
-- Output source location information
- if Sloc (Current_Error_Node) <= Standard_Location
- or else Sloc (Current_Error_Node) = No_Location
- then
- Write_Str ("| No source file position information available");
+ if Sloc (Current_Error_Node) <= No_Location then
+ if Fallback_Loc'Length > 0 then
+ Write_Str ("| Error detected around ");
+ Write_Str (Fallback_Loc);
+ else
+ Write_Str ("| No source file position information available");
+ end if;
+
End_Line;
else
Write_Str ("| Error detected at ");
-- Otherwise we use the standard fixed text
else
- Write_Str
- ("| Please submit bug report by email to report@gnat.com.");
- End_Line;
+ if Is_FSF_Version then
+ Write_Str
+ ("| Please submit a bug report; see" &
+ " http://gcc.gnu.org/bugs.html.");
+ End_Line;
+
+ elsif Is_GPL_Version then
+
+ Write_Str
+ ("| Please submit a bug report by email " &
+ "to report@adacore.com.");
+ End_Line;
+
+ Write_Str
+ ("| GAP members can alternatively use GNAT Tracker:");
+ End_Line;
- if not Public_Version then
Write_Str
- ("| Use a subject line meaningful to you" &
- " and us to track the bug.");
+ ("| http://www.adacore.com/ " &
+ "section 'send a report'.");
End_Line;
Write_Str
- ("| (include your customer number #nnn " &
- "in the subject line).");
+ ("| See gnatinfo.txt for full info on procedure " &
+ "for submitting bugs.");
+ End_Line;
+
+ else
+ Write_Str
+ ("| Please submit a bug report using GNAT Tracker:");
+ End_Line;
+
+ Write_Str
+ ("| http://www.adacore.com/gnattracker/ " &
+ "section 'send a report'.");
+ End_Line;
+
+ Write_Str
+ ("| alternatively submit a bug report by email " &
+ "to report@adacore.com,");
+ End_Line;
+
+ Write_Str
+ ("| including your customer number #nnn " &
+ "in the subject line.");
End_Line;
end if;
Write_Str
+ ("| Use a subject line meaningful to you" &
+ " and us to track the bug.");
+ End_Line;
+
+ Write_Str
("| Include the entire contents of this bug " &
"box in the report.");
End_Line;
("| (concatenated together with no headers between files).");
End_Line;
- if Public_Version then
+ if not Is_FSF_Version then
Write_Str
- ("| (use plain ASCII or MIME attachment).");
- End_Line;
-
- Write_Str
- ("| See gnatinfo.txt for full info on procedure " &
- "for submitting bugs.");
- End_Line;
-
- else
- Write_Str
- ("| (use plain ASCII or MIME attachment, or FTP "
- & "to your customer directory).");
- End_Line;
-
- Write_Str
- ("| See README.GNATPRO for full info on procedure " &
- "for submitting bugs.");
+ ("| Use plain ASCII or MIME attachment.");
End_Line;
end if;
end if;
Write_Eol;
Write_Line ("Please include these source files with error report");
+ Write_Line ("Note that list may not be accurate in some cases, ");
+ Write_Line ("so please double check that the problem can still ");
+ Write_Line ("be reproduced with the set of files listed.");
Write_Eol;
for U in Main_Unit .. Last_Unit loop
OSDN Git Service
