This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[gfortran,patch, RFC] Allow coredump and backtrace on runtime error


Hi all,

The attached patch (two files, with and without regenerated files)
adds support for dumping core files on runtime error, as well as
printing out backtraces. It adds two options in the front-end,
-fdump-core and -fbacktrace, the first one being off by default, and
the second one on. They're passed to the library, where they can be
overidden by the boolean environment variables GFORTRAN_ERROR_DUMPCORE
and GFORTRAN_ERROR_BACKTRACE.

The coredump is really simple: signal yourself with SIGQUIT, and
you're done. I added a warning on glibc systems if you requested a
coredump but your coredump size limit is set to zero (because it's
actually the default in many linux distros out there).

The backtrace is more complicated:
 -- on a non-glibc system, pstack is called if it's in your PATH, and
the backtrace is really the output of pstack (see [1] for an example
output; all backtrace examples are at the end of the mail).
 -- on a non-glibc system, if pstack is not in your PATH, no
backtrace is printed out; we can later add other backtrace mechanism
for specific platforms
 -- on glibc systems, if addr2line is available in the PATH, it's
used to resolve the addresses obtained by the glibc backtrace()
function (see [2], [3], [4], [5]).
 -- on glibc systems, if addr2line is not available or does not work
as expected, you get a pure glibc backtrace: see [6].

One point to note and two questions to debate:

 -- some internal libgfortran symbols appear in the dump when -static
is used; I make everything possible to exclude those prefixed with
_libgfortran, but static functions appear if static linking is used,
and they can't be recognized and filtered out. Maybe we could prefix
them anyway in the library; I'm about to clean up the library a bit
anyhow, so I might as well do it. Are there people who would object to
prefixing all library functions?

 -- I made -fbacktrace the default behaviour, because it doesn't cost
a CPU cycle during execution. Do you think that makes the output too
verbose?

 -- it will probably be best running the testsuite with
-fno-backtrace, to avoid wasting time printing nice backtraces for no
use :)  I haven't looked at it yet, but I will include a change in the
testsuite framework to that effect if/when I commit the patch.

Now, open fire, comments welcome!

(PS: the patch was bootstrapped and regtested on x86_64-linux, and
built and tested on sparc-solaris2.9.)

FX




The example backtraces:


[1] on sparc-solaris2.9 (using pstack):

Backtrace for this error:
11940:  ./a.out
0004d0b8 wait     ()
0001e450 _gfortrani_show_backtrace (1, 46d662, ffffffff, 5f, a, 1) + 20
00010c74 _gfortrani_sys_exit (2, ffbfee96, ffbfeeb4, 6a548, 5f, ffbfce20) + d8
00010e9c _gfortrani_generate_error (ffbff430, 138e, ffbfef9c,
ffbfefd8, 29, 0) + 12c
00020c3c _gfortrani_format_error (ffbff430, 0, 2, 2, 6a638, ffbff0aa) + d8
00012398 require_type (1, ffbff430, 1, 947c0, 0, 0) + 58
00013d18 formatted_transfer (ffbff430, 1, 6a1d8, 4, 4, 0) + 424
00011258 _gfortran_transfer_integer (ffbff430, 6a1d8, 4, 0, 93f68, 0) + 28
000102b8 gee_     (48b1c, 40, 94748, 72756e00, 0, ff00) + 60
00010248 bar_     (93f80, ffb6b8a0, ffffffff, 7efefeff, 74, 0) + 4
00010234 foo_     (46, 7f, 0, 0, 1, ffbff212) + 4
000102f8 MAIN__   (1, ffbff784, 0, 0, 0, 0) + 20
00010324 main     (0, ffbff784, ffbff78c, 8b57c, 0, 0) + 1c
000100dc _start   (0, 0, 0, 0, 0, 0) + 5c


[2] on x86_64-linux, with -g and dynamic linking:


Backtrace for this error:
 + function gee_ (0x400879)
   at line 10 of file u.f90
 + function bar_ (0x40080C)
   at line 6 of file u.f90
 + function foo_ (0x400801)
   at line 2 of file u.f90
 + in the main program
   at line 14 of file u.f90
 + /lib64/tls/libc.so.6(__libc_start_main+0xdb) [0x3ff241c4bb]


[3] on x86_64-linux, without -g and with dynamic linking:


Backtrace for this error:
 + function gee_ (0x400879)
 + function bar_ (0x40080C)
 + function foo_ (0x400801)
 + in the main program
 + /lib64/tls/libc.so.6(__libc_start_main+0xdb) [0x3ff241c4bb]


[4] on x86_64-linux, with -g and with static linking:


Backtrace for this error:
 + function require_type (0x40218C)
   at line 695 of file transfer.c
 + function formatted_transfer (0x40364F)
   at line 927 of file transfer.c
 + function gee_ (0x4002C5)
   at line 10 of file u.f90
 + function bar_ (0x400258)
   at line 6 of file u.f90
 + function foo_ (0x40024D)
   at line 2 of file u.f90
 + in the main program
   at line 14 of file u.f90
 + function __libc_start_main (0x419651)


[5] on x86_64-linux, without -g and with static linking:


Backtrace for this error:
 + function require_type (0x40218C)
   at line 695 of file transfer.c
 + function formatted_transfer (0x40364F)
   at line 927 of file transfer.c
 + function gee_ (0x4002C5)
 + function bar_ (0x400258)
 + function foo_ (0x40024D)
 + in the main program
 + function __libc_start_main (0x419651)


[6] on x86_64-linux, when addr2line is not available:


Backtrace for this error:
 + /utmp/coudert/gfortran/irun/lib64/libgfortran.so.2 [0x2a955682d6]
 + /utmp/coudert/gfortran/irun/lib64/libgfortran.so.2 [0x2a95569e95]
 + /utmp/coudert/gfortran/irun/lib64/libgfortran.so.2 [0x2a9556a09d]
 + /utmp/coudert/gfortran/irun/lib64/libgfortran.so.2 [0x2a955c5e70]
 + /utmp/coudert/gfortran/irun/lib64/libgfortran.so.2 [0x2a955cce9e]
 + /utmp/coudert/gfortran/irun/lib64/libgfortran.so.2 [0x2a955ce3af]
 + ./a.out [0x400879]
 + ./a.out [0x40080c]
 + ./a.out [0x400801]
 + ./a.out [0x4008af]
 + ./a.out [0x4008ec]
 + /lib64/tls/libc.so.6(__libc_start_main+0xdb) [0x3ff241c4bb]
 + ./a.out [0x40076a]

Attachment: backtrace_coredump.ChangeLog
Description: Binary data

Index: libgfortran/runtime/backtrace.c
===================================================================
--- libgfortran/runtime/backtrace.c	(revision 0)
+++ libgfortran/runtime/backtrace.c	(revision 0)
@@ -0,0 +1,331 @@
+/* Copyright (C) 2006 Free Software Foundation, Inc.
+   Contributed by François-Xavier Coudert
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT 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
+along with libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+#include "config.h"
+#include <stdio.h>
+#include <string.h>
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef HAVE_INTTYPES_H
+#include <inttypes.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_INTPTR_T
+# define INTPTR_T intptr_t
+#else
+# define INTPTR_T int
+#endif
+
+#ifdef HAVE_EXECINFO_H
+#include <execinfo.h>
+#endif
+
+#ifdef HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <ctype.h>
+
+#include "libgfortran.h"
+
+
+
+#ifndef HAVE_STRCASESTR
+#define HAVE_STRCASESTR 1
+static char *
+strcasestr (const char *s1, const char *s2)
+{
+  const char *p = s1;
+  const size_t len = strlen (s2);
+  const char u = *s2, v = isupper((int) *s2) ? tolower((int) *s2)
+				  : (islower((int) *s2) ? toupper((int) *s2)
+							: *s2);
+
+  while (1)
+    {
+      while (*p != u && *p != v && *p)
+	p++;
+      if (*p == 0)
+	return NULL;
+      if (strncasecmp (p, s2, len) == 0)
+	return (char *)p;
+    }
+}
+#endif
+
+#define CAN_FORK (defined(HAVE_FORK) && defined(HAVE_EXECVP) \
+		  && defined(HAVE_WAIT))
+#define GLIBC_BACKTRACE (defined(HAVE_BACKTRACE) \
+			 && defined(HAVE_BACKTRACE_SYMBOLS))
+#define CAN_PIPE (CAN_FORK && defined(HAVE_PIPE) \
+		  && defined(HAVE_DUP2) && defined(HAVE_FDOPEN) \
+		  && defined(HAVE_CLOSE))
+
+
+#if GLIBC_BACKTRACE
+static void
+dump_glibc_backtrace (int depth, char *str[])
+{
+  int i;
+
+  for (i = 0; i < depth; i++)
+    st_printf ("  + %s\n", str[i]);
+
+  free (str);
+}
+#endif
+
+/* show_backtrace displays the backtrace, currently obtained by means of
+   the glibc backtrace* functions.  */
+void
+show_backtrace (void)
+{
+#if GLIBC_BACKTRACE
+
+#define DEPTH 50
+#define BUFSIZE 1024
+
+  void *trace[DEPTH];
+  char **str;
+  int depth;
+
+  depth = backtrace (trace, DEPTH);
+  if (depth <= 0)
+    return;
+
+  str = backtrace_symbols (trace, depth);
+
+#if CAN_PIPE
+
+#ifndef STDIN_FILENO
+#define STDIN_FILENO 0
+#endif
+
+#ifndef STDOUT_FILENO
+#define STDOUT_FILENO 1
+#endif
+
+#ifndef STDERR_FILENO
+#define STDERR_FILENO 2
+#endif
+
+  /* We attempt to extract file and line information from addr2line.  */
+  do
+  {
+    /* Local variables.  */
+    int f[2], pid, line, i;
+    FILE *output;
+    char addr_buf[DEPTH][GFC_XTOA_BUF_SIZE], func[BUFSIZE], file[BUFSIZE];
+    char *p, *end;
+    const char *addr[DEPTH];
+
+    /* Write the list of addresses in hexadecimal format.  */
+    for (i = 0; i < depth; i++)
+      addr[i] = xtoa ((GFC_UINTEGER_LARGEST) (INTPTR_T) trace[i], addr_buf[i],
+		      sizeof (addr_buf[i]));
+
+    /* Don't output an error message if something goes wrong, we'll simply
+       fall back to the pstack and glibc backtraces.  */
+    if (pipe (f) != 0)
+      break;
+    if ((pid = fork ()) == -1)
+      break;
+
+    if (pid == 0)
+      {
+	/* Child process.  */
+#define NUM_FIXEDARGS 5
+	char *arg[DEPTH+NUM_FIXEDARGS+1];
+
+	close (f[0]);
+	close (STDIN_FILENO);
+	close (STDERR_FILENO);
+
+	if (dup2 (f[1], STDOUT_FILENO) == -1)
+	  _exit (0);
+	close (f[1]);
+
+	arg[0] = (char *) "addr2line";
+	arg[1] = (char *) "-e";
+	arg[2] = full_exe_path ();
+	arg[3] = (char *) "-f";
+	arg[4] = (char *) "-s";
+	for (i = 0; i < depth; i++)
+	  arg[NUM_FIXEDARGS+i] = (char *) addr[i];
+	arg[NUM_FIXEDARGS+depth] = NULL;
+	execvp (arg[0], arg);
+	_exit (0);
+#undef NUM_FIXEDARGS
+      }
+
+    /* Father process.  */
+    close (f[1]);
+    wait (NULL);
+    output = fdopen (f[0], "r");
+    i = -1;
+
+    if (fgets (func, sizeof(func), output))
+      {
+	st_printf ("\nBacktrace for this error:\n");
+
+	do
+	  {
+	    if (! fgets (file, sizeof(file), output))
+	      goto fallback;
+
+	    i++;
+
+	    for (p = func; *p != '\n' && *p != '\r'; p++)
+	      ;
+
+	    *p = '\0';
+
+	    /* Try to recognize the internal libgfortran functions.  */
+	    if (strncasecmp (func, "*_gfortran", 10) == 0
+		|| strncasecmp (func, "_gfortran", 9) == 0
+		|| strcmp (func, "main") == 0 || strcmp (func, "_start") == 0)
+	      continue;
+
+	    if (strcasestr (str[i], "libgfortran.so") != NULL
+		|| strcasestr (str[i], "libgfortran.dylib") != NULL
+		|| strcasestr (str[i], "libgfortran.a") != NULL)
+	      continue;
+
+	    /* If we only have the address, use the glibc backtrace.  */
+	    if (func[0] == '?' && func[1] == '?' && file[0] == '?'
+		&& file[1] == '?')
+	      {
+	        st_printf ("  + %s\n", str[i]);
+	        continue;
+	      }
+
+	    /* Extract the line number.  */
+	    for (end = NULL, p = file; *p; p++)
+	      if (*p == ':')
+		end = p;
+	    if (end != NULL)
+	      {
+		*end = '\0';
+		line = atoi (++end);
+	      }
+	    else
+	      line = -1;
+
+	    if (strcmp (func, "MAIN__") == 0)
+	      st_printf ("  + in the main program\n");
+	    else
+	      st_printf ("  + function %s (0x%s)\n", func, addr[i]);
+
+	    if (line <= 0 && strcmp (file, "??") == 0)
+	      continue;
+
+	    if (line <= 0)
+	      st_printf ("    from file %s\n", file);
+	    else
+	      st_printf ("    at line %d of file %s\n", line, file);
+	  }
+	while (fgets (func, sizeof(func), output));
+
+	free (str);
+	return;
+
+fallback:
+	st_printf ("** Something went wrong while running addr2line. **\n"
+		   "** Falling back  to a simpler  backtrace scheme. **\n");
+      }
+    }
+  while (0);
+
+#undef DEPTH
+#undef BUFSIZE
+
+#endif
+#endif
+
+#if CAN_FORK && defined(HAVE_GETPPID)
+  /* Try to call pstack.  */
+  do
+  {
+    /* Local variables.  */
+    int pid;
+
+    /* Don't output an error message if something goes wrong, we'll simply
+       fall back to the pstack and glibc backtraces.  */
+    if ((pid = fork ()) == -1)
+      break;
+
+    if (pid == 0)
+      {
+	/* Child process.  */
+#define NUM_ARGS 2
+	char *arg[NUM_ARGS+1];
+	char buf[20];
+
+	st_printf ("\nBacktrace for this error:\n");
+	arg[0] = (char *) "pstack";
+	snprintf (buf, sizeof(buf), "%d", (int) getppid ());
+	arg[1] = buf;
+	arg[2] = NULL;
+	execvp (arg[0], arg);
+#undef NUM_ARGS
+
+	/* pstack didn't work, so we fall back to dumping the glibc
+	   backtrace if we can.  */
+#if GLIBC_BACKTRACE
+	dump_glibc_backtrace (depth, str);
+#endif
+
+	_exit (0);
+      }
+
+    /* Father process.  */
+    wait (NULL);
+    return;
+  }
+  while(0);
+#endif
+
+#if GLIBC_BACKTRACE
+  /* Fallback to the glibc backtrace.  */
+  st_printf ("\nBacktrace for this error:\n");
+  dump_glibc_backtrace (depth, str);
+#endif
+}
Index: libgfortran/runtime/environ.c
===================================================================
--- libgfortran/runtime/environ.c	(revision 119124)
+++ libgfortran/runtime/environ.c	(working copy)
@@ -539,6 +539,15 @@
   {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted, show_string,
    "Set format for unformatted files", 0},
 
+  /* Behaviour when encoutering a runtime error.  */
+  {"GFORTRAN_ERROR_DUMPCORE", -1, &options.dump_core,
+    init_boolean, show_boolean,
+    "Dump a core file (if possible) on runtime error", -1},
+
+  {"GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace,
+    init_boolean, show_boolean,
+    "Print out a backtrace (if possible) on runtime error", -1},
+
   {NULL, 0, NULL, NULL, NULL, NULL, 0}
 };
 
Index: libgfortran/runtime/compile_options.c
===================================================================
--- libgfortran/runtime/compile_options.c	(revision 119124)
+++ libgfortran/runtime/compile_options.c	(working copy)
@@ -37,17 +37,21 @@
 
 
 /* Prototypes */
-extern void set_std (GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4);
+extern void set_std (GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4,
+		     GFC_INTEGER_4, GFC_INTEGER_4);
 export_proto(set_std);
 
 
 void
 set_std (GFC_INTEGER_4 warn_std, GFC_INTEGER_4 allow_std,
-	 GFC_INTEGER_4 pedantic)
+	 GFC_INTEGER_4 pedantic, GFC_INTEGER_4 dump_core,
+	 GFC_INTEGER_4 backtrace)
 {
   compile_options.pedantic = pedantic;
   compile_options.warn_std = warn_std;
   compile_options.allow_std = allow_std;
+  compile_options.dump_core = dump_core;
+  compile_options.backtrace = backtrace;
 }
 
 
@@ -61,6 +65,8 @@
   compile_options.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL
     | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F77 | GFC_STD_GNU | GFC_STD_LEGACY;
   compile_options.pedantic = 0;
+  compile_options.dump_core = 0;
+  compile_options.backtrace = 1;
 }
 
 /* Function called by the front-end to tell us the
Index: libgfortran/runtime/main.c
===================================================================
--- libgfortran/runtime/main.c	(revision 119124)
+++ libgfortran/runtime/main.c	(working copy)
@@ -32,9 +32,15 @@
 #include <string.h>
 #include <math.h>
 #include <stddef.h>
+#include <limits.h>
 
+#include "config.h"
 #include "libgfortran.h"
 
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
 /* Stupid function to be sure the constructor is always linked in, even
    in the case of static linking.  See PR libfortran/22298 for details.  */
 void
@@ -92,6 +98,44 @@
 }
 
 
+static const char *exe_path;
+
+/* Save the path under which the program was called, for use in the
+   backtrace routines.  */
+void
+store_exe_path (const char * argv0)
+{
+#ifndef PATH_MAX
+#define PATH_MAX 1024
+#endif
+
+#ifndef DIR_SEPARATOR   
+#define DIR_SEPARATOR '/'
+#endif
+
+  char buf[PATH_MAX], *cwd, *path;
+
+  if (argv0[0] == '/')
+    {
+      exe_path = argv0;
+      return;
+    }
+
+  cwd = getcwd (buf, sizeof (buf));
+
+  /* exe_path will be cwd + "/" + argv[0] + "\0" */
+  path = malloc (strlen (cwd) + 1 + strlen (argv0) + 1);
+  st_sprintf (path, "%s%c%s", cwd, DIR_SEPARATOR, argv0);
+  exe_path = path;
+}
+
+/* Return the full path of the executable.  */
+char *
+full_exe_path (void)
+{
+  return (char *) exe_path;
+}
+
 /* Initialize the runtime library.  */
 
 static void __attribute__((constructor))
Index: libgfortran/runtime/error.c
===================================================================
--- libgfortran/runtime/error.c	(revision 119124)
+++ libgfortran/runtime/error.c	(working copy)
@@ -36,10 +36,76 @@
 #include <float.h>
 #include <errno.h>
 
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef HAVE_SYS_RESOURCE_H
+#include <sys/resource.h>
+#endif
+
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+
 #include "libgfortran.h"
 #include "../io/io.h"
 #include "../io/unix.h"
 
+#ifdef __MINGW32__
+#define HAVE_GETPID 1
+#include <process.h>
+#endif
+
+
+/* sys_exit()-- Terminate the program with an exit code */
+
+void
+sys_exit (int code)
+{
+  /* Show error backtrace if possible.  */
+  if (code != 0 && code != 4
+      && (options.backtrace == 1
+	  || (options.backtrace == -1 && compile_options.backtrace == 1)))
+    show_backtrace ();
+
+  /* Dump core if requested.  */
+  if (code != 0
+      && (options.dump_core == 1
+	  || (options.dump_core == -1 && compile_options.dump_core == 1)))
+    {
+#if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
+      /* Warn if a core file cannot be produced because
+	 of core size limit.  */
+
+      struct rlimit core_limit;
+
+      if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0)
+	st_printf ("** Warning: a core dump was requested, but the core size"
+		   "limit\n**          is currently zero.\n\n");
+#endif
+      
+      
+#if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
+      kill (getpid (), SIGQUIT);
+#else
+      st_printf ("Core dump not possible, sorry.");
+#endif
+    }
+
+  exit (code);
+}
+
+
+
 /* Error conditions.  The tricky part here is printing a message when
  * it is the I/O subsystem that is severely wounded.  Our goal is to
  * try and print something making the fewest assumptions possible,
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h	(revision 119124)
+++ libgfortran/libgfortran.h	(working copy)
@@ -354,6 +354,7 @@
   int fpu_round, fpu_precision, fpe;
 
   int sighup, sigint;
+  int dump_core, backtrace;
 }
 options_t;
 
@@ -369,6 +370,8 @@
   int allow_std;
   int pedantic;
   int convert;
+  int dump_core;
+  int backtrace;
   size_t record_marker;
 }
 compile_options_t;
@@ -483,6 +486,17 @@
 extern void get_args (int *, char ***);
 internal_proto(get_args);
 
+extern void store_exe_path (const char *);
+export_proto(store_exe_path);
+
+extern char * full_exe_path (void);
+internal_proto(full_exe_path);
+
+/* backtrace.c */
+
+extern void show_backtrace (void);
+internal_proto(show_backtrace);
+
 /* error.c */
 
 #define GFC_ITOA_BUF_SIZE (sizeof (GFC_INTEGER_LARGEST) * 3 + 2)
@@ -490,6 +504,9 @@
 #define GFC_OTOA_BUF_SIZE (sizeof (GFC_INTEGER_LARGEST) * 3 + 1)
 #define GFC_BTOA_BUF_SIZE (sizeof (GFC_INTEGER_LARGEST) * 8 + 1)
 
+extern void sys_exit (int) __attribute__ ((noreturn));
+internal_proto(sys_exit);
+
 extern const char *gfc_itoa (GFC_INTEGER_LARGEST, char *, size_t);
 internal_proto(gfc_itoa);
 
@@ -512,9 +529,6 @@
 extern const char *get_oserror (void);
 internal_proto(get_oserror);
 
-extern void sys_exit (int) __attribute__ ((noreturn));
-internal_proto(sys_exit);
-
 extern int st_printf (const char *, ...)
   __attribute__ ((format (printf, 1, 2)));
 internal_proto(st_printf);
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac	(revision 119124)
+++ libgfortran/configure.ac	(working copy)
@@ -160,7 +160,7 @@
 AC_HAVE_HEADERS(stdlib.h stdio.h string.h stddef.h math.h unistd.h signal.h)
 AC_CHECK_HEADERS(time.h sys/params.h sys/time.h sys/times.h sys/resource.h)
 AC_CHECK_HEADERS(sys/types.h sys/stat.h sys/wait.h floatingpoint.h ieeefp.h)
-AC_CHECK_HEADERS(fenv.h fptrap.h float.h)
+AC_CHECK_HEADERS(fenv.h fptrap.h float.h execinfo.h)
 AC_CHECK_HEADER([complex.h],[AC_DEFINE([HAVE_COMPLEX_H], [1], [complex.h exists])])
 GCC_HEADER_STDINT(gstdint.h)
 
@@ -172,14 +172,18 @@
 AC_CHECK_FUNCS(getrusage times mkstemp strtof strtold snprintf ftruncate chsize)
 AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror)
 AC_CHECK_FUNCS(sleep time ttyname signal alarm ctime clock access fork execl)
-AC_CHECK_FUNCS(wait setmode)
+AC_CHECK_FUNCS(wait setmode execvp pipe dup2 close fdopen strcasestr getrlimit)
 
+# Check for glibc backtrace functions
+AC_CHECK_FUNCS(backtrace backtrace_symbols)
+
 # Check for types
 AC_CHECK_TYPES([intptr_t])
 
 # Check libc for getgid, getpid, getuid
 AC_CHECK_LIB([c],[getgid],[AC_DEFINE([HAVE_GETGID],[1],[libc includes getgid])])
 AC_CHECK_LIB([c],[getpid],[AC_DEFINE([HAVE_GETPID],[1],[libc includes getpid])])
+AC_CHECK_LIB([c],[getppid],[AC_DEFINE([HAVE_GETPPID],[1],[libc includes getppid])])
 AC_CHECK_LIB([c],[getuid],[AC_DEFINE([HAVE_GETUID],[1],[libc includes getuid])])
 
 # Check for C99 (and other IEEE) math functions
Index: libgfortran/io/unix.c
===================================================================
--- libgfortran/io/unix.c	(revision 119124)
+++ libgfortran/io/unix.c	(working copy)
@@ -327,15 +327,6 @@
 }
 
 
-/* sys_exit()-- Terminate the program with an exit code */
-
-void
-sys_exit (int code)
-{
-  exit (code);
-}
-
-
 /*********************************************************************
     File descriptor stream functions
 *********************************************************************/
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am	(revision 119124)
+++ libgfortran/Makefile.am	(working copy)
@@ -102,6 +102,7 @@
 runtime/in_unpack_generic.c
 
 gfor_src= \
+runtime/backtrace.c \
 runtime/compile_options.c \
 runtime/environ.c \
 runtime/error.c \
Index: libgfortran/fmain.c
===================================================================
--- libgfortran/fmain.c	(revision 119124)
+++ libgfortran/fmain.c	(working copy)
@@ -10,9 +10,13 @@
 int
 main (int argc, char *argv[])
 {
+  /* Store the path of the executable file.  */
+  store_exe_path (argv[0]);
+
   /* Set up the runtime environment.  */
   set_args (argc, argv);
 
+
   /* Call the Fortran main program.  Internally this is a function
      called MAIN__ */
   MAIN__ ();
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 119124)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -1647,6 +1647,8 @@
   int flag_f2c;
   int flag_automatic;
   int flag_backslash;
+  int flag_dump_core;
+  int flag_backtrace;
   int flag_external_blas;
   int blas_matmul_limit;
   int flag_cray_pointer;
Index: gcc/fortran/lang.opt
===================================================================
--- gcc/fortran/lang.opt	(revision 119124)
+++ gcc/fortran/lang.opt	(working copy)
@@ -85,6 +85,10 @@
 Fortran
 Specify that backslash in string introduces an escape character
 
+fbacktrace
+Fortran
+Produce a backtrace when a runtime error is encountered
+
 fblas-matmul-limit=
 Fortran RejectNegative Joined UInteger
 -fblas-matmul-limit=<n>        Size of the smallest matrix for which matmul will use BLAS
@@ -133,6 +137,10 @@
 Fortran
 Allow dollar signs in entity names
 
+fdump-core
+Fortran
+Dump a core file when a runtime error happens
+
 fdump-parse-tree
 Fortran
 Display the code tree after parsing
Index: gcc/fortran/invoke.texi
===================================================================
--- gcc/fortran/invoke.texi	(revision 119124)
+++ gcc/fortran/invoke.texi	(working copy)
@@ -121,7 +121,7 @@
 -ffixed-line-length-@var{n}  -ffixed-line-length-none @gol
 -ffree-line-length-@var{n}  -ffree-line-length-none @gol
 -fdefault-double-8  -fdefault-integer-8  -fdefault-real-8 @gol
--fcray-pointer  -fopenmp  -frange-check }
+-fcray-pointer  -fopenmp  -frange-check -fno-backslash }
 
 @item Error and Warning Options
 @xref{Error and Warning Options,,Options to Request or Suppress Errors
@@ -134,7 +134,8 @@
 
 @item Debugging Options
 @xref{Debugging Options,,Options for Debugging Your Program or GCC}.
-@gccoptlist{-fdump-parse-tree  -ffpe-trap=@var{list}}
+@gccoptlist{-fdump-parse-tree  -ffpe-trap=@var{list} @gol
+-fdump-core -fno-backtrace}
 
 @item Directory Options
 @xref{Directory Options,,Options for Directory Search}.
@@ -569,6 +570,24 @@
 @samp{underflow} (underflow in a floating point operation),
 @samp{precision} (loss of precision during operation) and @samp{denormal}
 (operation produced a denormal value).
+
+@cindex -fno-backtrace option
+@cindex options, -fno-backtrace
+@item -fno-backtrace
+@cindex backtrace
+@cindex trace
+Specify that, when a runtime error is encountered, the Fortran runtime
+library should not try to output a backtrace of the error. This options
+only has influence for compilation of the Fortran main program.
+
+@cindex -fdump-core option
+@cindex options, -fdump-core
+@item -fdump-core
+@cindex core
+Request that a core dump be written to disk when a runtime error is
+encountered, on systems that support such core files. This options only
+has influence for compilation of the Fortran main program.
+
 @end table
 
 @xref{Debugging Options,,Options for Debugging Your Program or GCC,
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 119124)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -2363,9 +2363,11 @@
   gfor_fndecl_set_std =
     gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
 				    void_type_node,
-				    3,
+				    5,
 				    gfc_int4_type_node,
 				    gfc_int4_type_node,
+				    gfc_int4_type_node,
+				    gfc_int4_type_node,
 				    gfc_int4_type_node);
 
   gfor_fndecl_set_convert =
@@ -3134,6 +3136,14 @@
       arglist = gfc_chainon_list (arglist,
 				  build_int_cst (gfc_int4_type_node,
 						 pedantic));
+      arglist = gfc_chainon_list (arglist,
+				  build_int_cst (gfc_int4_type_node,
+						 gfc_option.flag_dump_core));
+
+      arglist = gfc_chainon_list (arglist,
+				  build_int_cst (gfc_int4_type_node,
+						 gfc_option.flag_backtrace));
+
       tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
       gfc_add_expr_to_block (&body, tmp);
     }
Index: gcc/fortran/options.c
===================================================================
--- gcc/fortran/options.c	(revision 119124)
+++ gcc/fortran/options.c	(working copy)
@@ -79,6 +79,8 @@
   gfc_option.flag_preprocessed = 0;
   gfc_option.flag_automatic = 1;
   gfc_option.flag_backslash = 1;
+  gfc_option.flag_dump_core = 0;
+  gfc_option.flag_backtrace = 1;
   gfc_option.flag_external_blas = 0;
   gfc_option.blas_matmul_limit = 30;
   gfc_option.flag_cray_pointer = 0;
@@ -437,6 +439,14 @@
       gfc_option.flag_backslash = value;
       break;
       
+    case OPT_fdump_core:
+      gfc_option.flag_dump_core = value;
+      break;
+      
+    case OPT_fbacktrace:
+      gfc_option.flag_backtrace = value;
+      break;
+      
     case OPT_fcray_pointer:
       gfc_option.flag_cray_pointer = value;
       break;
Index: libgfortran/configure
===================================================================
--- libgfortran/configure	(revision 119124)
+++ libgfortran/configure	(working copy)
@@ -6274,7 +6274,8 @@
 
 
 
-for ac_header in fenv.h fptrap.h float.h
+
+for ac_header in fenv.h fptrap.h float.h execinfo.h
 do
 as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
 if eval "test \"\${$as_ac_Header+set}\" = set"; then
@@ -10095,7 +10096,14 @@
 
 
 
-for ac_func in wait setmode
+
+
+
+
+
+
+
+for ac_func in wait setmode execvp pipe dup2 close fdopen strcasestr getrlimit
 do
 as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
 echo "$as_me:$LINENO: checking for $ac_func" >&5
@@ -10202,6 +10210,116 @@
 done
 
 
+# Check for glibc backtrace functions
+
+
+for ac_func in backtrace backtrace_symbols
+do
+as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
+echo "$as_me:$LINENO: checking for $ac_func" >&5
+echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
+if eval "test \"\${$as_ac_var+set}\" = set"; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  if test x$gcc_no_link = xyes; then
+  { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5
+echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;}
+   { (exit 1); exit 1; }; }
+fi
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
+   For example, HP-UX 11i <limits.h> declares gettimeofday.  */
+#define $ac_func innocuous_$ac_func
+
+/* System header to define __stub macros and hopefully few prototypes,
+    which can conflict with char $ac_func (); below.
+    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
+    <limits.h> exists even on freestanding compilers.  */
+
+#ifdef __STDC__
+# include <limits.h>
+#else
+# include <assert.h>
+#endif
+
+#undef $ac_func
+
+/* Override any gcc2 internal prototype to avoid an error.  */
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+/* We use char because int might match the return type of a gcc2
+   builtin and then its argument prototype would still apply.  */
+char $ac_func ();
+/* The GNU C library defines this for functions which it implements
+    to always fail with ENOSYS.  Some functions are actually named
+    something starting with __ and the normal name is an alias.  */
+#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
+choke me
+#else
+char (*f) () = $ac_func;
+#endif
+#ifdef __cplusplus
+}
+#endif
+
+int
+main ()
+{
+return f != $ac_func;
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
+  (eval $ac_link) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest$ac_exeext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  eval "$as_ac_var=yes"
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+eval "$as_ac_var=no"
+fi
+rm -f conftest.err conftest.$ac_objext \
+      conftest$ac_exeext conftest.$ac_ext
+fi
+echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
+echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
+if test `eval echo '${'$as_ac_var'}'` = yes; then
+  cat >>confdefs.h <<_ACEOF
+#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
+_ACEOF
+
+fi
+done
+
+
 # Check for types
 echo "$as_me:$LINENO: checking for intptr_t" >&5
 echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6
@@ -10424,6 +10542,83 @@
 
 fi
 
+echo "$as_me:$LINENO: checking for getppid in -lc" >&5
+echo $ECHO_N "checking for getppid in -lc... $ECHO_C" >&6
+if test "${ac_cv_lib_c_getppid+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  ac_check_lib_save_LIBS=$LIBS
+LIBS="-lc  $LIBS"
+if test x$gcc_no_link = xyes; then
+  { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5
+echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;}
+   { (exit 1); exit 1; }; }
+fi
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+/* Override any gcc2 internal prototype to avoid an error.  */
+#ifdef __cplusplus
+extern "C"
+#endif
+/* We use char because int might match the return type of a gcc2
+   builtin and then its argument prototype would still apply.  */
+char getppid ();
+int
+main ()
+{
+getppid ();
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
+  (eval $ac_link) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest$ac_exeext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  ac_cv_lib_c_getppid=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ac_cv_lib_c_getppid=no
+fi
+rm -f conftest.err conftest.$ac_objext \
+      conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+echo "$as_me:$LINENO: result: $ac_cv_lib_c_getppid" >&5
+echo "${ECHO_T}$ac_cv_lib_c_getppid" >&6
+if test $ac_cv_lib_c_getppid = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_GETPPID 1
+_ACEOF
+
+fi
+
 echo "$as_me:$LINENO: checking for getuid in -lc" >&5
 echo $ECHO_N "checking for getuid in -lc... $ECHO_C" >&6
 if test "${ac_cv_lib_c_getuid+set}" = set; then
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in	(revision 119124)
+++ libgfortran/Makefile.in	(working copy)
@@ -70,8 +70,8 @@
 toolexeclibLTLIBRARIES_INSTALL = $(INSTALL)
 LTLIBRARIES = $(myexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES)
 libgfortran_la_LIBADD =
-am__objects_1 = compile_options.lo environ.lo error.lo fpu.lo main.lo \
-	memory.lo pause.lo stop.lo string.lo select.lo
+am__objects_1 = backtrace.lo compile_options.lo environ.lo error.lo \
+	fpu.lo main.lo memory.lo pause.lo stop.lo string.lo select.lo
 am__objects_2 = all_l4.lo all_l8.lo all_l16.lo
 am__objects_3 = any_l4.lo any_l8.lo any_l16.lo
 am__objects_4 = count_4_l4.lo count_8_l4.lo count_16_l4.lo \
@@ -461,6 +461,7 @@
 runtime/in_unpack_generic.c
 
 gfor_src = \
+runtime/backtrace.c \
 runtime/compile_options.c \
 runtime/environ.c \
 runtime/error.c \
@@ -1515,6 +1516,9 @@
 .c.lo:
 	$(LTCOMPILE) -c -o $@ $<
 
+backtrace.lo: runtime/backtrace.c
+	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o backtrace.lo `test -f 'runtime/backtrace.c' || echo '$(srcdir)/'`runtime/backtrace.c
+
 compile_options.lo: runtime/compile_options.c
 	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o compile_options.lo `test -f 'runtime/compile_options.c' || echo '$(srcdir)/'`runtime/compile_options.c
 
Index: libgfortran/runtime/backtrace.c
===================================================================
--- libgfortran/runtime/backtrace.c	(revision 0)
+++ libgfortran/runtime/backtrace.c	(revision 0)
@@ -0,0 +1,331 @@
+/* Copyright (C) 2006 Free Software Foundation, Inc.
+   Contributed by François-Xavier Coudert
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT 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
+along with libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+#include "config.h"
+#include <stdio.h>
+#include <string.h>
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef HAVE_INTTYPES_H
+#include <inttypes.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_INTPTR_T
+# define INTPTR_T intptr_t
+#else
+# define INTPTR_T int
+#endif
+
+#ifdef HAVE_EXECINFO_H
+#include <execinfo.h>
+#endif
+
+#ifdef HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <ctype.h>
+
+#include "libgfortran.h"
+
+
+
+#ifndef HAVE_STRCASESTR
+#define HAVE_STRCASESTR 1
+static char *
+strcasestr (const char *s1, const char *s2)
+{
+  const char *p = s1;
+  const size_t len = strlen (s2);
+  const char u = *s2, v = isupper((int) *s2) ? tolower((int) *s2)
+				  : (islower((int) *s2) ? toupper((int) *s2)
+							: *s2);
+
+  while (1)
+    {
+      while (*p != u && *p != v && *p)
+	p++;
+      if (*p == 0)
+	return NULL;
+      if (strncasecmp (p, s2, len) == 0)
+	return (char *)p;
+    }
+}
+#endif
+
+#define CAN_FORK (defined(HAVE_FORK) && defined(HAVE_EXECVP) \
+		  && defined(HAVE_WAIT))
+#define GLIBC_BACKTRACE (defined(HAVE_BACKTRACE) \
+			 && defined(HAVE_BACKTRACE_SYMBOLS))
+#define CAN_PIPE (CAN_FORK && defined(HAVE_PIPE) \
+		  && defined(HAVE_DUP2) && defined(HAVE_FDOPEN) \
+		  && defined(HAVE_CLOSE))
+
+
+#if GLIBC_BACKTRACE
+static void
+dump_glibc_backtrace (int depth, char *str[])
+{
+  int i;
+
+  for (i = 0; i < depth; i++)
+    st_printf ("  + %s\n", str[i]);
+
+  free (str);
+}
+#endif
+
+/* show_backtrace displays the backtrace, currently obtained by means of
+   the glibc backtrace* functions.  */
+void
+show_backtrace (void)
+{
+#if GLIBC_BACKTRACE
+
+#define DEPTH 50
+#define BUFSIZE 1024
+
+  void *trace[DEPTH];
+  char **str;
+  int depth;
+
+  depth = backtrace (trace, DEPTH);
+  if (depth <= 0)
+    return;
+
+  str = backtrace_symbols (trace, depth);
+
+#if CAN_PIPE
+
+#ifndef STDIN_FILENO
+#define STDIN_FILENO 0
+#endif
+
+#ifndef STDOUT_FILENO
+#define STDOUT_FILENO 1
+#endif
+
+#ifndef STDERR_FILENO
+#define STDERR_FILENO 2
+#endif
+
+  /* We attempt to extract file and line information from addr2line.  */
+  do
+  {
+    /* Local variables.  */
+    int f[2], pid, line, i;
+    FILE *output;
+    char addr_buf[DEPTH][GFC_XTOA_BUF_SIZE], func[BUFSIZE], file[BUFSIZE];
+    char *p, *end;
+    const char *addr[DEPTH];
+
+    /* Write the list of addresses in hexadecimal format.  */
+    for (i = 0; i < depth; i++)
+      addr[i] = xtoa ((GFC_UINTEGER_LARGEST) (INTPTR_T) trace[i], addr_buf[i],
+		      sizeof (addr_buf[i]));
+
+    /* Don't output an error message if something goes wrong, we'll simply
+       fall back to the pstack and glibc backtraces.  */
+    if (pipe (f) != 0)
+      break;
+    if ((pid = fork ()) == -1)
+      break;
+
+    if (pid == 0)
+      {
+	/* Child process.  */
+#define NUM_FIXEDARGS 5
+	char *arg[DEPTH+NUM_FIXEDARGS+1];
+
+	close (f[0]);
+	close (STDIN_FILENO);
+	close (STDERR_FILENO);
+
+	if (dup2 (f[1], STDOUT_FILENO) == -1)
+	  _exit (0);
+	close (f[1]);
+
+	arg[0] = (char *) "addr2line";
+	arg[1] = (char *) "-e";
+	arg[2] = full_exe_path ();
+	arg[3] = (char *) "-f";
+	arg[4] = (char *) "-s";
+	for (i = 0; i < depth; i++)
+	  arg[NUM_FIXEDARGS+i] = (char *) addr[i];
+	arg[NUM_FIXEDARGS+depth] = NULL;
+	execvp (arg[0], arg);
+	_exit (0);
+#undef NUM_FIXEDARGS
+      }
+
+    /* Father process.  */
+    close (f[1]);
+    wait (NULL);
+    output = fdopen (f[0], "r");
+    i = -1;
+
+    if (fgets (func, sizeof(func), output))
+      {
+	st_printf ("\nBacktrace for this error:\n");
+
+	do
+	  {
+	    if (! fgets (file, sizeof(file), output))
+	      goto fallback;
+
+	    i++;
+
+	    for (p = func; *p != '\n' && *p != '\r'; p++)
+	      ;
+
+	    *p = '\0';
+
+	    /* Try to recognize the internal libgfortran functions.  */
+	    if (strncasecmp (func, "*_gfortran", 10) == 0
+		|| strncasecmp (func, "_gfortran", 9) == 0
+		|| strcmp (func, "main") == 0 || strcmp (func, "_start") == 0)
+	      continue;
+
+	    if (strcasestr (str[i], "libgfortran.so") != NULL
+		|| strcasestr (str[i], "libgfortran.dylib") != NULL
+		|| strcasestr (str[i], "libgfortran.a") != NULL)
+	      continue;
+
+	    /* If we only have the address, use the glibc backtrace.  */
+	    if (func[0] == '?' && func[1] == '?' && file[0] == '?'
+		&& file[1] == '?')
+	      {
+	        st_printf ("  + %s\n", str[i]);
+	        continue;
+	      }
+
+	    /* Extract the line number.  */
+	    for (end = NULL, p = file; *p; p++)
+	      if (*p == ':')
+		end = p;
+	    if (end != NULL)
+	      {
+		*end = '\0';
+		line = atoi (++end);
+	      }
+	    else
+	      line = -1;
+
+	    if (strcmp (func, "MAIN__") == 0)
+	      st_printf ("  + in the main program\n");
+	    else
+	      st_printf ("  + function %s (0x%s)\n", func, addr[i]);
+
+	    if (line <= 0 && strcmp (file, "??") == 0)
+	      continue;
+
+	    if (line <= 0)
+	      st_printf ("    from file %s\n", file);
+	    else
+	      st_printf ("    at line %d of file %s\n", line, file);
+	  }
+	while (fgets (func, sizeof(func), output));
+
+	free (str);
+	return;
+
+fallback:
+	st_printf ("** Something went wrong while running addr2line. **\n"
+		   "** Falling back  to a simpler  backtrace scheme. **\n");
+      }
+    }
+  while (0);
+
+#undef DEPTH
+#undef BUFSIZE
+
+#endif
+#endif
+
+#if CAN_FORK && defined(HAVE_GETPPID)
+  /* Try to call pstack.  */
+  do
+  {
+    /* Local variables.  */
+    int pid;
+
+    /* Don't output an error message if something goes wrong, we'll simply
+       fall back to the pstack and glibc backtraces.  */
+    if ((pid = fork ()) == -1)
+      break;
+
+    if (pid == 0)
+      {
+	/* Child process.  */
+#define NUM_ARGS 2
+	char *arg[NUM_ARGS+1];
+	char buf[20];
+
+	st_printf ("\nBacktrace for this error:\n");
+	arg[0] = (char *) "pstack";
+	snprintf (buf, sizeof(buf), "%d", (int) getppid ());
+	arg[1] = buf;
+	arg[2] = NULL;
+	execvp (arg[0], arg);
+#undef NUM_ARGS
+
+	/* pstack didn't work, so we fall back to dumping the glibc
+	   backtrace if we can.  */
+#if GLIBC_BACKTRACE
+	dump_glibc_backtrace (depth, str);
+#endif
+
+	_exit (0);
+      }
+
+    /* Father process.  */
+    wait (NULL);
+    return;
+  }
+  while(0);
+#endif
+
+#if GLIBC_BACKTRACE
+  /* Fallback to the glibc backtrace.  */
+  st_printf ("\nBacktrace for this error:\n");
+  dump_glibc_backtrace (depth, str);
+#endif
+}
Index: libgfortran/runtime/environ.c
===================================================================
--- libgfortran/runtime/environ.c	(revision 119124)
+++ libgfortran/runtime/environ.c	(working copy)
@@ -539,6 +539,15 @@
   {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted, show_string,
    "Set format for unformatted files", 0},
 
+  /* Behaviour when encoutering a runtime error.  */
+  {"GFORTRAN_ERROR_DUMPCORE", -1, &options.dump_core,
+    init_boolean, show_boolean,
+    "Dump a core file (if possible) on runtime error", -1},
+
+  {"GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace,
+    init_boolean, show_boolean,
+    "Print out a backtrace (if possible) on runtime error", -1},
+
   {NULL, 0, NULL, NULL, NULL, NULL, 0}
 };
 
Index: libgfortran/runtime/compile_options.c
===================================================================
--- libgfortran/runtime/compile_options.c	(revision 119124)
+++ libgfortran/runtime/compile_options.c	(working copy)
@@ -37,17 +37,21 @@
 
 
 /* Prototypes */
-extern void set_std (GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4);
+extern void set_std (GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4,
+		     GFC_INTEGER_4, GFC_INTEGER_4);
 export_proto(set_std);
 
 
 void
 set_std (GFC_INTEGER_4 warn_std, GFC_INTEGER_4 allow_std,
-	 GFC_INTEGER_4 pedantic)
+	 GFC_INTEGER_4 pedantic, GFC_INTEGER_4 dump_core,
+	 GFC_INTEGER_4 backtrace)
 {
   compile_options.pedantic = pedantic;
   compile_options.warn_std = warn_std;
   compile_options.allow_std = allow_std;
+  compile_options.dump_core = dump_core;
+  compile_options.backtrace = backtrace;
 }
 
 
@@ -61,6 +65,8 @@
   compile_options.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL
     | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F77 | GFC_STD_GNU | GFC_STD_LEGACY;
   compile_options.pedantic = 0;
+  compile_options.dump_core = 0;
+  compile_options.backtrace = 1;
 }
 
 /* Function called by the front-end to tell us the
Index: libgfortran/runtime/main.c
===================================================================
--- libgfortran/runtime/main.c	(revision 119124)
+++ libgfortran/runtime/main.c	(working copy)
@@ -32,9 +32,15 @@
 #include <string.h>
 #include <math.h>
 #include <stddef.h>
+#include <limits.h>
 
+#include "config.h"
 #include "libgfortran.h"
 
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
 /* Stupid function to be sure the constructor is always linked in, even
    in the case of static linking.  See PR libfortran/22298 for details.  */
 void
@@ -92,6 +98,44 @@
 }
 
 
+static const char *exe_path;
+
+/* Save the path under which the program was called, for use in the
+   backtrace routines.  */
+void
+store_exe_path (const char * argv0)
+{
+#ifndef PATH_MAX
+#define PATH_MAX 1024
+#endif
+
+#ifndef DIR_SEPARATOR   
+#define DIR_SEPARATOR '/'
+#endif
+
+  char buf[PATH_MAX], *cwd, *path;
+
+  if (argv0[0] == '/')
+    {
+      exe_path = argv0;
+      return;
+    }
+
+  cwd = getcwd (buf, sizeof (buf));
+
+  /* exe_path will be cwd + "/" + argv[0] + "\0" */
+  path = malloc (strlen (cwd) + 1 + strlen (argv0) + 1);
+  st_sprintf (path, "%s%c%s", cwd, DIR_SEPARATOR, argv0);
+  exe_path = path;
+}
+
+/* Return the full path of the executable.  */
+char *
+full_exe_path (void)
+{
+  return (char *) exe_path;
+}
+
 /* Initialize the runtime library.  */
 
 static void __attribute__((constructor))
Index: libgfortran/runtime/error.c
===================================================================
--- libgfortran/runtime/error.c	(revision 119124)
+++ libgfortran/runtime/error.c	(working copy)
@@ -36,10 +36,76 @@
 #include <float.h>
 #include <errno.h>
 
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef HAVE_SYS_RESOURCE_H
+#include <sys/resource.h>
+#endif
+
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+
 #include "libgfortran.h"
 #include "../io/io.h"
 #include "../io/unix.h"
 
+#ifdef __MINGW32__
+#define HAVE_GETPID 1
+#include <process.h>
+#endif
+
+
+/* sys_exit()-- Terminate the program with an exit code */
+
+void
+sys_exit (int code)
+{
+  /* Show error backtrace if possible.  */
+  if (code != 0 && code != 4
+      && (options.backtrace == 1
+	  || (options.backtrace == -1 && compile_options.backtrace == 1)))
+    show_backtrace ();
+
+  /* Dump core if requested.  */
+  if (code != 0
+      && (options.dump_core == 1
+	  || (options.dump_core == -1 && compile_options.dump_core == 1)))
+    {
+#if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
+      /* Warn if a core file cannot be produced because
+	 of core size limit.  */
+
+      struct rlimit core_limit;
+
+      if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0)
+	st_printf ("** Warning: a core dump was requested, but the core size"
+		   "limit\n**          is currently zero.\n\n");
+#endif
+      
+      
+#if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
+      kill (getpid (), SIGQUIT);
+#else
+      st_printf ("Core dump not possible, sorry.");
+#endif
+    }
+
+  exit (code);
+}
+
+
+
 /* Error conditions.  The tricky part here is printing a message when
  * it is the I/O subsystem that is severely wounded.  Our goal is to
  * try and print something making the fewest assumptions possible,
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h	(revision 119124)
+++ libgfortran/libgfortran.h	(working copy)
@@ -354,6 +354,7 @@
   int fpu_round, fpu_precision, fpe;
 
   int sighup, sigint;
+  int dump_core, backtrace;
 }
 options_t;
 
@@ -369,6 +370,8 @@
   int allow_std;
   int pedantic;
   int convert;
+  int dump_core;
+  int backtrace;
   size_t record_marker;
 }
 compile_options_t;
@@ -483,6 +486,17 @@
 extern void get_args (int *, char ***);
 internal_proto(get_args);
 
+extern void store_exe_path (const char *);
+export_proto(store_exe_path);
+
+extern char * full_exe_path (void);
+internal_proto(full_exe_path);
+
+/* backtrace.c */
+
+extern void show_backtrace (void);
+internal_proto(show_backtrace);
+
 /* error.c */
 
 #define GFC_ITOA_BUF_SIZE (sizeof (GFC_INTEGER_LARGEST) * 3 + 2)
@@ -490,6 +504,9 @@
 #define GFC_OTOA_BUF_SIZE (sizeof (GFC_INTEGER_LARGEST) * 3 + 1)
 #define GFC_BTOA_BUF_SIZE (sizeof (GFC_INTEGER_LARGEST) * 8 + 1)
 
+extern void sys_exit (int) __attribute__ ((noreturn));
+internal_proto(sys_exit);
+
 extern const char *gfc_itoa (GFC_INTEGER_LARGEST, char *, size_t);
 internal_proto(gfc_itoa);
 
@@ -512,9 +529,6 @@
 extern const char *get_oserror (void);
 internal_proto(get_oserror);
 
-extern void sys_exit (int) __attribute__ ((noreturn));
-internal_proto(sys_exit);
-
 extern int st_printf (const char *, ...)
   __attribute__ ((format (printf, 1, 2)));
 internal_proto(st_printf);
Index: libgfortran/config.h.in
===================================================================
--- libgfortran/config.h.in	(revision 119124)
+++ libgfortran/config.h.in	(working copy)
@@ -84,6 +84,12 @@
 /* Define to 1 if the target supports __attribute__((visibility(...))). */
 #undef HAVE_ATTRIBUTE_VISIBILITY
 
+/* Define to 1 if you have the `backtrace' function. */
+#undef HAVE_BACKTRACE
+
+/* Define to 1 if you have the `backtrace_symbols' function. */
+#undef HAVE_BACKTRACE_SYMBOLS
+
 /* Define if fpclassify is broken. */
 #undef HAVE_BROKEN_FPCLASSIFY
 
@@ -174,6 +180,9 @@
 /* libm includes clogl */
 #undef HAVE_CLOGL
 
+/* Define to 1 if you have the `close' function. */
+#undef HAVE_CLOSE
+
 /* complex.h exists */
 #undef HAVE_COMPLEX_H
 
@@ -264,6 +273,9 @@
 /* Define to 1 if you have the `ctime' function. */
 #undef HAVE_CTIME
 
+/* Define to 1 if you have the `dup2' function. */
+#undef HAVE_DUP2
+
 /* libm includes erf */
 #undef HAVE_ERF
 
@@ -282,9 +294,15 @@
 /* libm includes erfl */
 #undef HAVE_ERFL
 
+/* Define to 1 if you have the <execinfo.h> header file. */
+#undef HAVE_EXECINFO_H
+
 /* Define to 1 if you have the `execl' function. */
 #undef HAVE_EXECL
 
+/* Define to 1 if you have the `execvp' function. */
+#undef HAVE_EXECVP
+
 /* libm includes exp */
 #undef HAVE_EXP
 
@@ -303,6 +321,9 @@
 /* libm includes fabsl */
 #undef HAVE_FABSL
 
+/* Define to 1 if you have the `fdopen' function. */
+#undef HAVE_FDOPEN
+
 /* libm includes feenableexcept */
 #undef HAVE_FEENABLEEXCEPT
 
@@ -366,6 +387,12 @@
 /* libc includes getpid */
 #undef HAVE_GETPID
 
+/* libc includes getppid */
+#undef HAVE_GETPPID
+
+/* Define to 1 if you have the `getrlimit' function. */
+#undef HAVE_GETRLIMIT
+
 /* Define to 1 if you have the `getrusage' function. */
 #undef HAVE_GETRUSAGE
 
@@ -477,6 +504,9 @@
 /* Define to 1 if you have the `perror' function. */
 #undef HAVE_PERROR
 
+/* Define to 1 if you have the `pipe' function. */
+#undef HAVE_PIPE
+
 /* libm includes pow */
 #undef HAVE_POW
 
@@ -558,6 +588,9 @@
 /* Define to 1 if you have the <stdlib.h> header file. */
 #undef HAVE_STDLIB_H
 
+/* Define to 1 if you have the `strcasestr' function. */
+#undef HAVE_STRCASESTR
+
 /* Define to 1 if you have the `strerror' function. */
 #undef HAVE_STRERROR
 
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac	(revision 119124)
+++ libgfortran/configure.ac	(working copy)
@@ -160,7 +160,7 @@
 AC_HAVE_HEADERS(stdlib.h stdio.h string.h stddef.h math.h unistd.h signal.h)
 AC_CHECK_HEADERS(time.h sys/params.h sys/time.h sys/times.h sys/resource.h)
 AC_CHECK_HEADERS(sys/types.h sys/stat.h sys/wait.h floatingpoint.h ieeefp.h)
-AC_CHECK_HEADERS(fenv.h fptrap.h float.h)
+AC_CHECK_HEADERS(fenv.h fptrap.h float.h execinfo.h)
 AC_CHECK_HEADER([complex.h],[AC_DEFINE([HAVE_COMPLEX_H], [1], [complex.h exists])])
 GCC_HEADER_STDINT(gstdint.h)
 
@@ -172,14 +172,18 @@
 AC_CHECK_FUNCS(getrusage times mkstemp strtof strtold snprintf ftruncate chsize)
 AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror)
 AC_CHECK_FUNCS(sleep time ttyname signal alarm ctime clock access fork execl)
-AC_CHECK_FUNCS(wait setmode)
+AC_CHECK_FUNCS(wait setmode execvp pipe dup2 close fdopen strcasestr getrlimit)
 
+# Check for glibc backtrace functions
+AC_CHECK_FUNCS(backtrace backtrace_symbols)
+
 # Check for types
 AC_CHECK_TYPES([intptr_t])
 
 # Check libc for getgid, getpid, getuid
 AC_CHECK_LIB([c],[getgid],[AC_DEFINE([HAVE_GETGID],[1],[libc includes getgid])])
 AC_CHECK_LIB([c],[getpid],[AC_DEFINE([HAVE_GETPID],[1],[libc includes getpid])])
+AC_CHECK_LIB([c],[getppid],[AC_DEFINE([HAVE_GETPPID],[1],[libc includes getppid])])
 AC_CHECK_LIB([c],[getuid],[AC_DEFINE([HAVE_GETUID],[1],[libc includes getuid])])
 
 # Check for C99 (and other IEEE) math functions
Index: libgfortran/io/unix.c
===================================================================
--- libgfortran/io/unix.c	(revision 119124)
+++ libgfortran/io/unix.c	(working copy)
@@ -327,15 +327,6 @@
 }
 
 
-/* sys_exit()-- Terminate the program with an exit code */
-
-void
-sys_exit (int code)
-{
-  exit (code);
-}
-
-
 /*********************************************************************
     File descriptor stream functions
 *********************************************************************/
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am	(revision 119124)
+++ libgfortran/Makefile.am	(working copy)
@@ -102,6 +102,7 @@
 runtime/in_unpack_generic.c
 
 gfor_src= \
+runtime/backtrace.c \
 runtime/compile_options.c \
 runtime/environ.c \
 runtime/error.c \
Index: libgfortran/fmain.c
===================================================================
--- libgfortran/fmain.c	(revision 119124)
+++ libgfortran/fmain.c	(working copy)
@@ -10,9 +10,13 @@
 int
 main (int argc, char *argv[])
 {
+  /* Store the path of the executable file.  */
+  store_exe_path (argv[0]);
+
   /* Set up the runtime environment.  */
   set_args (argc, argv);
 
+
   /* Call the Fortran main program.  Internally this is a function
      called MAIN__ */
   MAIN__ ();
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 119124)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -1647,6 +1647,8 @@
   int flag_f2c;
   int flag_automatic;
   int flag_backslash;
+  int flag_dump_core;
+  int flag_backtrace;
   int flag_external_blas;
   int blas_matmul_limit;
   int flag_cray_pointer;
Index: gcc/fortran/error.c
===================================================================
--- gcc/fortran/error.c	(revision 119124)
+++ gcc/fortran/error.c	(working copy)
@@ -378,69 +378,151 @@
 static void ATTRIBUTE_GCC_GFC(2,0)
 error_print (const char *type, const char *format0, va_list argp)
 {
-  char c, c_arg[MAX_ARGS], *cp_arg[MAX_ARGS];
-  int n, have_l1, i_arg[MAX_ARGS];
-  locus *l1, *l2, *loc;
+  enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_CHAR, TYPE_STRING,
+	 NOTYPE };
+  struct
+  {
+    int type;
+    int pos;
+    union
+    {
+      locus * locval;
+      int intval;
+      char charval;
+      char * stringval;
+    } u;
+  } percent[MAX_ARGS], arg[MAX_ARGS];
+
+  char c;
+  int i, n, have_l1, use_dollars, pos, maxpos;
+  locus *l1, *l2;
   const char *format;
 
-  l1 = l2 = loc = NULL;
+  l1 = l2 = NULL;
 
   have_l1 = 0;
+  use_dollars = -1;
+  pos = -1;
+  maxpos = -1;
 
   n = 0;
   format = format0;
 
+  for (i = 0; i < MAX_ARGS; i++)
+    {
+      percent[i].type = NOTYPE;
+      arg[i].pos = -1;
+    }
+
+  /* First parse the format string for position specifiers.  */
   while (*format)
     {
       c = *format++;
-      if (c == '%')
+      if (c != '%')
+	continue;
+
+      if (*format == '%')
+	continue;
+
+      if (ISDIGIT (*format))
 	{
-	  c = *format++;
+	  /* This is a position specifier.  */
+	  gcc_assert (use_dollars != 0);
+	  use_dollars = 1;
 
-	  switch (c)
-	    {
-	    case '%':
-	      break;
+	  pos = atoi(format) - 1;
+	  gcc_assert (pos >= 0);
+	  while (ISDIGIT(*format))
+	    format++;
+	  gcc_assert (*format++ == '$');
+	}
+      c = *format++;
 
-	    case 'L':
-	      loc = va_arg (argp, locus *);
-	      /* Fall through */
+      if (use_dollars == -1)
+	use_dollars = 0;
+      if (!use_dollars)
+	pos++;
 
-	    case 'C':
-	      if (c == 'C')
-		loc = &gfc_current_locus;
+      if (pos > maxpos)
+	maxpos = pos;
 
-	      if (have_l1)
-		{
-		  l2 = loc;
-		}
-	      else
-		{
-		  l1 = loc;
-		  have_l1 = 1;
-		}
-	      break;
+      switch (c)
+	{
+	  case 'C':
+	    percent[pos].type = TYPE_CURRENTLOC;
+	    break;
 
-	    case 'd':
-	    case 'i':
-	      i_arg[n++] = va_arg (argp, int);
-	      break;
+	  case 'L':
+	    percent[pos].type = TYPE_LOCUS;
+	    break;
 
-	    case 'c':
-	      c_arg[n++] = va_arg (argp, int);
-	      break;
+	  case 'd':
+	  case 'i':
+	    percent[pos].type = TYPE_INTEGER;
+	    break;
 
-	    case 's':
-	      cp_arg[n++] = va_arg (argp, char *);
-	      break;
+	  case 'c':
+	    percent[pos].type = TYPE_CHAR;
+	    break;
 
-	    case '\0':
-	      format--;
-	      break;
+	  case 's':
+	    percent[pos].type = TYPE_STRING;
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+	}
+
+      arg[n++].pos = pos;
+    }
+
+  /* The convert the values for each %-style argument.  */
+  for (pos = 0; pos <= maxpos; pos++)
+    {
+      gcc_assert (percent[pos].type != NOTYPE);
+      switch (percent[pos].type)
+	{
+	  case TYPE_CURRENTLOC:
+	    percent[pos].u.locval = &gfc_current_locus;
+	    break;
+
+	  case TYPE_LOCUS:
+	    percent[pos].u.locval = va_arg (argp, locus *);
+	    break;
+
+	  case TYPE_INTEGER:
+	    percent[pos].u.intval = va_arg (argp, int);
+	    break;
+
+	  case TYPE_CHAR:
+	    percent[pos].u.charval = (char) va_arg (argp, int);
+	    break;
+
+	  case TYPE_STRING:
+	    percent[pos].u.stringval = va_arg (argp, char *);
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+	}
+
+      if (percent[pos].type == TYPE_CURRENTLOC
+	  || percent[pos].type == TYPE_LOCUS)
+	{
+	  if (have_l1)
+	    l2 = percent[pos].u.locval;
+	  else
+	    {
+	      l1 = percent[pos].u.locval;
+	      have_l1 = 1;
 	    }
 	}
+	
     }
 
+  for (n = 0; arg[n].pos >= 0; n++)
+    arg[n].u = percent[arg[n].pos].u;
+
   /* Show the current loci if we have to.  */
   if (have_l1)
     show_loci (l1, l2);
@@ -464,6 +546,13 @@
 	}
 
       format++;
+      if (ISDIGIT(*format))
+	{
+	  while (ISDIGIT(*format))
+	    format++;
+	  format++;
+	}
+	
       switch (*format)
 	{
 	case '%':
@@ -471,22 +560,23 @@
 	  break;
 
 	case 'c':
-	  error_char (c_arg[n++]);
+	  error_char (arg[n++].u.charval);
 	  break;
 
 	case 's':
-	  error_string (cp_arg[n++]);
+	  error_string (arg[n++].u.stringval);
 	  break;
 
 	case 'd':
 	case 'i':
-	  error_integer (i_arg[n++]);
+	  error_integer (arg[n++].u.intval);
 	  break;
 
 	case 'C':		/* Current locus */
 	case 'L':		/* Specified locus */
 	  error_string (have_l1 ? "(2)" : "(1)");
 	  have_l1 = 1;
+	  n++;
 	  break;
 
 	case '\0':
Index: gcc/fortran/lang.opt
===================================================================
--- gcc/fortran/lang.opt	(revision 119124)
+++ gcc/fortran/lang.opt	(working copy)
@@ -85,6 +85,10 @@
 Fortran
 Specify that backslash in string introduces an escape character
 
+fbacktrace
+Fortran
+Produce a backtrace when a runtime error is encountered
+
 fblas-matmul-limit=
 Fortran RejectNegative Joined UInteger
 -fblas-matmul-limit=<n>        Size of the smallest matrix for which matmul will use BLAS
@@ -133,6 +137,10 @@
 Fortran
 Allow dollar signs in entity names
 
+fdump-core
+Fortran
+Dump a core file when a runtime error happens
+
 fdump-parse-tree
 Fortran
 Display the code tree after parsing
Index: gcc/fortran/invoke.texi
===================================================================
--- gcc/fortran/invoke.texi	(revision 119124)
+++ gcc/fortran/invoke.texi	(working copy)
@@ -121,7 +121,7 @@
 -ffixed-line-length-@var{n}  -ffixed-line-length-none @gol
 -ffree-line-length-@var{n}  -ffree-line-length-none @gol
 -fdefault-double-8  -fdefault-integer-8  -fdefault-real-8 @gol
--fcray-pointer  -fopenmp  -frange-check }
+-fcray-pointer  -fopenmp  -frange-check -fno-backslash }
 
 @item Error and Warning Options
 @xref{Error and Warning Options,,Options to Request or Suppress Errors
@@ -134,7 +134,8 @@
 
 @item Debugging Options
 @xref{Debugging Options,,Options for Debugging Your Program or GCC}.
-@gccoptlist{-fdump-parse-tree  -ffpe-trap=@var{list}}
+@gccoptlist{-fdump-parse-tree  -ffpe-trap=@var{list} @gol
+-fdump-core -fno-backtrace}
 
 @item Directory Options
 @xref{Directory Options,,Options for Directory Search}.
@@ -569,6 +570,24 @@
 @samp{underflow} (underflow in a floating point operation),
 @samp{precision} (loss of precision during operation) and @samp{denormal}
 (operation produced a denormal value).
+
+@cindex -fno-backtrace option
+@cindex options, -fno-backtrace
+@item -fno-backtrace
+@cindex backtrace
+@cindex trace
+Specify that, when a runtime error is encountered, the Fortran runtime
+library should not try to output a backtrace of the error. This options
+only has influence for compilation of the Fortran main program.
+
+@cindex -fdump-core option
+@cindex options, -fdump-core
+@item -fdump-core
+@cindex core
+Request that a core dump be written to disk when a runtime error is
+encountered, on systems that support such core files. This options only
+has influence for compilation of the Fortran main program.
+
 @end table
 
 @xref{Debugging Options,,Options for Debugging Your Program or GCC,
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 119124)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -2363,9 +2363,11 @@
   gfor_fndecl_set_std =
     gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
 				    void_type_node,
-				    3,
+				    5,
 				    gfc_int4_type_node,
 				    gfc_int4_type_node,
+				    gfc_int4_type_node,
+				    gfc_int4_type_node,
 				    gfc_int4_type_node);
 
   gfor_fndecl_set_convert =
@@ -3134,6 +3136,14 @@
       arglist = gfc_chainon_list (arglist,
 				  build_int_cst (gfc_int4_type_node,
 						 pedantic));
+      arglist = gfc_chainon_list (arglist,
+				  build_int_cst (gfc_int4_type_node,
+						 gfc_option.flag_dump_core));
+
+      arglist = gfc_chainon_list (arglist,
+				  build_int_cst (gfc_int4_type_node,
+						 gfc_option.flag_backtrace));
+
       tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
       gfc_add_expr_to_block (&body, tmp);
     }
Index: gcc/fortran/options.c
===================================================================
--- gcc/fortran/options.c	(revision 119124)
+++ gcc/fortran/options.c	(working copy)
@@ -79,6 +79,8 @@
   gfc_option.flag_preprocessed = 0;
   gfc_option.flag_automatic = 1;
   gfc_option.flag_backslash = 1;
+  gfc_option.flag_dump_core = 0;
+  gfc_option.flag_backtrace = 1;
   gfc_option.flag_external_blas = 0;
   gfc_option.blas_matmul_limit = 30;
   gfc_option.flag_cray_pointer = 0;
@@ -437,6 +439,14 @@
       gfc_option.flag_backslash = value;
       break;
       
+    case OPT_fdump_core:
+      gfc_option.flag_dump_core = value;
+      break;
+      
+    case OPT_fbacktrace:
+      gfc_option.flag_backtrace = value;
+      break;
+      
     case OPT_fcray_pointer:
       gfc_option.flag_cray_pointer = value;
       break;

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]