------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- C O M P E R R -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- Copyright (C) 1992-2001 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. -- -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- This package contains routines called when a fatal internal compiler -- error is detected. Calls to these routines cause termination of the -- current compilation with appropriate error output. with Atree; use Atree; with Debug; use Debug; with Errout; use Errout; with Fname; use Fname; with Gnatvsn; use Gnatvsn; with Lib; use Lib; with Namet; use Namet; with Osint; use Osint; with Output; use Output; with Sinput; use Sinput; with Sprint; use Sprint; with Sdefault; use Sdefault; with Treepr; use Treepr; with Types; use Types; with Ada.Exceptions; use Ada.Exceptions; with System.Soft_Links; use System.Soft_Links; package body Comperr is ---------------- -- Local Data -- ---------------- Abort_In_Progress : Boolean := False; -- Used to prevent runaway recursion if something segfaults -- while processing a previous abort. ----------------------- -- Local Subprograms -- ----------------------- procedure Repeat_Char (Char : Character; Col : Nat; After : Character); -- Output Char until current column is at or past Col, and then output -- the character given by After (if column is already past Col on entry, -- then the effect is simply to output the After character). -------------------- -- Compiler_Abort -- -------------------- procedure Compiler_Abort (X : String; Code : Integer := 0) is procedure End_Line; -- Add blanks up to column 76, and then a final vertical bar procedure End_Line is begin Repeat_Char (' ', 76, '|'); Write_Eol; end End_Line; Public_Version : constant Boolean := (Gnat_Version_String (5) = 'p'); -- Start of processing for Compiler_Abort begin -- Prevent recursion through Compiler_Abort, e.g. via SIGSEGV. if Abort_In_Progress then Exit_Program (E_Abort); end if; 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. -- Debug flag K disables this behavior (useful for debugging) if Errors_Detected /= 0 and then not Debug_Flag_K then Errout.Finalize; Set_Standard_Error; Write_Str ("compilation abandoned due to previous error"); Write_Eol; Set_Standard_Output; Source_Dump; Tree_Dump; Exit_Program (E_Errors); -- Otherwise give message with details of the abort else Set_Standard_Error; -- Generate header for bug box Write_Char ('+'); Repeat_Char ('=', 29, 'G'); Write_Str ("NAT BUG DETECTED"); Repeat_Char ('=', 76, '+'); Write_Eol; -- Output GNAT version identification Write_Str ("| "); Write_Str (Gnat_Version_String); Write_Str (" ("); -- Output target name, deleting junk final reverse slash if Target_Name.all (Target_Name.all'Last) = '\' or else Target_Name.all (Target_Name.all'Last) = '/' then Write_Str (Target_Name.all (1 .. Target_Name.all'Last - 1)); else Write_Str (Target_Name.all); end if; -- Output identification of error Write_Str (") "); if X'Length + Column > 76 then if Code < 0 then Write_Str ("GCC error:"); end if; End_Line; Write_Str ("| "); end if; if X'Length > 70 then declare Last_Blank : Integer := 70; begin for P in 40 .. 69 loop if X (P) = ' ' then Last_Blank := P; end if; end loop; Write_Str (X (1 .. Last_Blank)); End_Line; Write_Str ("| "); Write_Str (X (Last_Blank + 1 .. X'Length)); end; else Write_Str (X); end if; if Code > 0 then Write_Str (", Code="); Write_Int (Int (Code)); elsif Code = 0 then -- For exception case, get exception message from the TSD. Note -- that it would be neater and cleaner to pass the exception -- message (obtained from Exception_Message) as a parameter to -- Compiler_Abort, but we can't do this quite yet since it would -- cause bootstrap path problems for 3.10 to 3.11. Write_Char (' '); Write_Str (Exception_Message (Get_Current_Excep.all.all)); end if; End_Line; -- 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"); End_Line; else Write_Str ("| Error detected at "); Write_Location (Sloc (Current_Error_Node)); End_Line; end if; -- There are two cases now. If the file gnat_bug.box exists, -- we use the contents of this file at this point. declare Lo : Source_Ptr; Hi : Source_Ptr; Src : Source_Buffer_Ptr; begin Namet.Unlock; Name_Buffer (1 .. 12) := "gnat_bug.box"; Name_Len := 12; Read_Source_File (Name_Enter, 0, Hi, Src); -- If we get a Src file, we use it if Src /= null then Lo := 0; Outer : while Lo < Hi loop Write_Str ("| "); Inner : loop exit Inner when Src (Lo) = ASCII.CR or else Src (Lo) = ASCII.LF; Write_Char (Src (Lo)); Lo := Lo + 1; end loop Inner; End_Line; while Lo <= Hi and then (Src (Lo) = ASCII.CR or else Src (Lo) = ASCII.LF) loop Lo := Lo + 1; end loop; end loop Outer; -- Otherwise we use the standard fixed text else Write_Str ("| Please submit bug report by email to report@gnat.com."); End_Line; if not Public_Version then Write_Str ("| Use a subject line meaningful to you" & " and us to track the bug."); End_Line; Write_Str ("| (include your customer number #nnn " & "in the subject line)."); End_Line; end if; Write_Str ("| Include the entire contents of this bug " & "box in the report."); End_Line; Write_Str ("| Include the exact gcc or gnatmake command " & "that you entered."); End_Line; Write_Str ("| Also include sources listed below in gnatchop format"); End_Line; Write_Str ("| (concatenated together with no headers between files)."); End_Line; if Public_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."); End_Line; end if; end if; end; -- Complete output of bug box Write_Char ('+'); Repeat_Char ('=', 76, '+'); Write_Eol; if Debug_Flag_3 then Write_Eol; Write_Eol; Print_Tree_Node (Current_Error_Node); Write_Eol; end if; Write_Eol; Write_Line ("Please include these source files with error report"); Write_Eol; for U in Main_Unit .. Last_Unit loop begin if not Is_Internal_File_Name (File_Name (Source_Index (U))) then Write_Name (Full_File_Name (Source_Index (U))); Write_Eol; end if; -- No point in double bug box if we blow up trying to print -- the list of file names! Output informative msg and quit. exception when others => Write_Str ("list may be incomplete"); exit; end; end loop; Write_Eol; Set_Standard_Output; Tree_Dump; Source_Dump; raise Unrecoverable_Error; end if; end Compiler_Abort; ----------------- -- Repeat_Char -- ----------------- procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is begin while Column < Col loop Write_Char (Char); end loop; Write_Char (After); end Repeat_Char; end Comperr;