diff options
Diffstat (limited to 'gcc/ada/comperr.adb')
| -rw-r--r-- | gcc/ada/comperr.adb | 357 |
1 files changed, 357 insertions, 0 deletions
diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb new file mode 100644 index 00000000000..e92e0c4a97e --- /dev/null +++ b/gcc/ada/comperr.adb @@ -0,0 +1,357 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C O M P E R R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.57 $ +-- -- +-- 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 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 + -- 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; |