diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/comperr.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/comperr.adb | 555 |
1 files changed, 0 insertions, 555 deletions
diff --git a/gcc-4.8/gcc/ada/comperr.adb b/gcc-4.8/gcc/ada/comperr.adb deleted file mode 100644 index ac620e622..000000000 --- a/gcc-4.8/gcc/ada/comperr.adb +++ /dev/null @@ -1,555 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- C O M P E R R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, 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 AdaCore. -- --- -- ------------------------------------------------------------------------------- - --- 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 Gnatvsn; use Gnatvsn; -with Lib; use Lib; -with Namet; use Namet; -with Opt; use Opt; -with Osint; use Osint; -with Output; use Output; -with Sinfo; use Sinfo; -with Sinput; use Sinput; -with Sprint; use Sprint; -with Sdefault; use Sdefault; -with Targparm; use Targparm; -with Treepr; use Treepr; -with Types; use Types; - -with Ada.Exceptions; use Ada.Exceptions; - -with System.OS_Lib; use System.OS_Lib; -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; - 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; - - 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 - Cancel_Special_Output; - - -- Prevent recursion through Compiler_Abort, e.g. via SIGSEGV - - if Abort_In_Progress then - Exit_Program (E_Abort); - end if; - - Abort_In_Progress := True; - - -- Generate a "standard" error message instead of a bug box in case of - -- .NET compiler, since we do not support all constructs of the - -- language. Of course ideally, we should detect this before bombing - -- on e.g. an assertion error, but in practice most of these bombs - -- are due to a legitimate case of a construct not being supported (in - -- a sense they all are, since for sure we are not supporting something - -- if we bomb!) By giving this message, we provide a more reasonable - -- practical interface, since giving scary bug boxes on unsupported - -- features is definitely not helpful. - - -- Similarly if we are generating SCIL, an error message is sufficient - -- instead of generating a bug box. - - -- Note that the call to Error_Msg_N below sets Serious_Errors_Detected - -- to 1, so we use the regular mechanism below in order to display a - -- "compilation abandoned" message and exit, so we still know we have - -- this case (and -gnatdk can still be used to get the bug box). - - if (VM_Target = CLI_Target or else CodePeer_Mode) - and then Serious_Errors_Detected = 0 - and then not Debug_Flag_K - and then Sloc (Current_Error_Node) > No_Location - then - if VM_Target = CLI_Target then - Error_Msg_N - ("unsupported construct in this context", - Current_Error_Node); - else - Error_Msg_N ("cannot generate 'S'C'I'L", Current_Error_Node); - end if; - end if; - - -- If we are in CodePeer mode, we must also delete SCIL files - - if CodePeer_Mode then - Delete_SCIL_Files; - end if; - - -- 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 Serious_Errors_Detected /= 0 and then not Debug_Flag_K then - Errout.Finalize (Last_Call => True); - Errout.Output_Messages; - - 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 39 .. 68 loop - if X (XF + P) = ' ' then - Last_Blank := P; - end if; - end loop; - - Write_Str (X (XF .. XF - 1 + Last_Blank)); - End_Line; - Write_Str ("| "); - Write_Str (X (XF + Last_Blank .. X'Last)); - 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) <= 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 "); - 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 - 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; - - Write_Str - ("| http://www.adacore.com/ " & - "section 'send a report'."); - End_Line; - - Write_Str - ("| 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; - - 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 not Is_FSF_Version then - Write_Str - ("| Use plain ASCII or MIME attachment."); - 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_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_Line ("Consider also -gnatd.n switch (see debug.adb)."); - Write_Eol; - - begin - Dump_Source_File_Names; - - -- If we blow up trying to print the list of file names, just output - -- informative msg and continue. - - exception - when others => - Write_Str ("list may be incomplete"); - end; - - Write_Eol; - Set_Standard_Output; - - Tree_Dump; - Source_Dump; - raise Unrecoverable_Error; - end if; - end Compiler_Abort; - - ----------------------- - -- Delete_SCIL_Files -- - ----------------------- - - procedure Delete_SCIL_Files is - Main : Node_Id; - Unit_Name : Node_Id; - - Success : Boolean; - pragma Unreferenced (Success); - - procedure Decode_Name_Buffer; - -- Replace "__" by "." in Name_Buffer, and adjust Name_Len accordingly - - ------------------------ - -- Decode_Name_Buffer -- - ------------------------ - - procedure Decode_Name_Buffer is - J : Natural; - K : Natural; - - begin - J := 1; - K := 0; - while J <= Name_Len loop - K := K + 1; - - if J < Name_Len - and then Name_Buffer (J) = '_' - and then Name_Buffer (J + 1) = '_' - then - Name_Buffer (K) := '.'; - J := J + 1; - else - Name_Buffer (K) := Name_Buffer (J); - end if; - - J := J + 1; - end loop; - - Name_Len := K; - end Decode_Name_Buffer; - - -- Start of processing for Delete_SCIL_Files - - begin - -- If parsing was not successful, no Main_Unit is available, so return - -- immediately. - - if Main_Source_File = No_Source_File then - return; - end if; - - -- Retrieve unit name, and remove old versions of SCIL/<unit>.scil and - -- SCIL/<unit>__body.scil, ditto for .scilx files. - - Main := Unit (Cunit (Main_Unit)); - - case Nkind (Main) is - when N_Subprogram_Body | N_Package_Declaration => - Unit_Name := Defining_Unit_Name (Specification (Main)); - - when N_Package_Body => - Unit_Name := Corresponding_Spec (Main); - - when N_Package_Renaming_Declaration => - Unit_Name := Defining_Unit_Name (Main); - - -- No SCIL file generated for generic package declarations - - when N_Generic_Package_Declaration => - return; - - -- Should never happen, but can be ignored in production - - when others => - pragma Assert (False); - return; - end case; - - case Nkind (Unit_Name) is - when N_Defining_Identifier => - Get_Name_String (Chars (Unit_Name)); - - when N_Defining_Program_Unit_Name => - Get_Name_String (Chars (Defining_Identifier (Unit_Name))); - Decode_Name_Buffer; - - -- Should never happen, but can be ignored in production - - when others => - pragma Assert (False); - return; - end case; - - Delete_File - ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scil", Success); - Delete_File - ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scilx", Success); - Delete_File - ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scil", Success); - Delete_File - ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scilx", Success); - end Delete_SCIL_Files; - - ----------------- - -- 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; |