aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/comperr.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/ada/comperr.adb')
-rw-r--r--gcc-4.9/gcc/ada/comperr.adb555
1 files changed, 555 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/comperr.adb b/gcc-4.9/gcc/ada/comperr.adb
new file mode 100644
index 000000000..13646a5c1
--- /dev/null
+++ b/gcc-4.9/gcc/ada/comperr.adb
@@ -0,0 +1,555 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- C O M P E R R --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2013, 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;