* gfortran.h (gfc_option_t): Add flag_backtrace field.

	* lang.opt: Add -fbacktrace option.
	* invoke.texi: Document the new option.
	* trans-decl.c (gfc_build_builtin_function_decls): Add new
	option to the call to set_std.
	* options.c (gfc_init_options, gfc_handle_option): Handle the
	new option.

	* runtime/backtrace.c: New file.
	* runtime/environ.c (variable_table): New GFORTRAN_ERROR_BACKTRACE
	environment variable.
	* runtime/compile_options.c (set_std): Add new argument.
	* runtime/main.c (store_exe_path, full_exe_path): New functions.
	* runtime/error.c (sys_exit): Add call to show_backtrace.
	* libgfortran.h (options_t): New backtrace field.
	(store_exe_path, full_exe_path, show_backtrace): New prototypes.
	* configure.ac: Add checks for execinfo.h, execvp, pipe, dup2,
	close, fdopen, strcasestr, getrlimit, backtrace, backtrace_symbols
	and getppid.
	* Makefile.am: Add runtime/backtrace.c.
	* fmain.c (main): Add call to store_exe_path.
	* Makefile.in: Renegerate.
	* config.h.in: Renegerate.
	* configure: Regenerate.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@122954 138bc75d-0d04-0410-961f-82ee72b054a4

13 files changed, 671 insertions, 12 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index d793b727b26..70cdf75faad 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,22 @@
+2007-03-15  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* runtime/backtrace.c: New file.
+	* runtime/environ.c (variable_table): New GFORTRAN_ERROR_BACKTRACE
+	environment variable.
+	* runtime/compile_options.c (set_std): Add new argument.
+	* runtime/main.c (store_exe_path, full_exe_path): New functions.
+	* runtime/error.c (sys_exit): Add call to show_backtrace.
+	* libgfortran.h (options_t): New backtrace field.
+	(store_exe_path, full_exe_path, show_backtrace): New prototypes.
+	* configure.ac: Add checks for execinfo.h, execvp, pipe, dup2,
+	close, fdopen, strcasestr, getrlimit, backtrace, backtrace_symbols
+	and getppid.
+	* Makefile.am: Add runtime/backtrace.c.
+	* fmain.c (main): Add call to store_exe_path.
+	* Makefile.in: Renegerate.
+	* config.h.in: Renegerate.
+	* configure: Regenerate.
+
 2007-03-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/31051
diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am
index f306cc9f706..2338b9b8c4d 100644
--- a/libgfortran/Makefile.am
+++ b/libgfortran/Makefile.am
@@ -97,6 +97,7 @@ runtime/in_pack_generic.c \
 runtime/in_unpack_generic.c
 
 gfor_src= \
+runtime/backtrace.c \
 runtime/compile_options.c \
 runtime/environ.c \
 runtime/error.c \
diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in
index c1ff053d0d7..8e10976943e 100644
--- a/libgfortran/Makefile.in
+++ b/libgfortran/Makefile.in
@@ -71,8 +71,8 @@ myexeclibLTLIBRARIES_INSTALL = $(INSTALL)
 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 \
@@ -476,6 +476,7 @@ runtime/in_pack_generic.c \
 runtime/in_unpack_generic.c
 
 gfor_src = \
+runtime/backtrace.c \
 runtime/compile_options.c \
 runtime/environ.c \
 runtime/error.c \
@@ -1141,6 +1142,7 @@ distclean-compile:
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l8.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/associated.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backtrace.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/c99_functions.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/chdir.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/chmod.Plo@am__quote@
@@ -1942,6 +1944,13 @@ f2c_specifics.lo: intrinsics/f2c_specifics.F90
 @AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 @am__fastdepCC_FALSE@	$(LTCOMPILE) -c -o $@ $<
 
+backtrace.lo: runtime/backtrace.c
+@am__fastdepCC_TRUE@	if $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT backtrace.lo -MD -MP -MF "$(DEPDIR)/backtrace.Tpo" -c -o backtrace.lo `test -f 'runtime/backtrace.c' || echo '$(srcdir)/'`runtime/backtrace.c; \
+@am__fastdepCC_TRUE@	then mv -f "$(DEPDIR)/backtrace.Tpo" "$(DEPDIR)/backtrace.Plo"; else rm -f "$(DEPDIR)/backtrace.Tpo"; exit 1; fi
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='runtime/backtrace.c' object='backtrace.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(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
 @am__fastdepCC_TRUE@	if $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT compile_options.lo -MD -MP -MF "$(DEPDIR)/compile_options.Tpo" -c -o compile_options.lo `test -f 'runtime/compile_options.c' || echo '$(srcdir)/'`runtime/compile_options.c; \
 @am__fastdepCC_TRUE@	then mv -f "$(DEPDIR)/compile_options.Tpo" "$(DEPDIR)/compile_options.Plo"; else rm -f "$(DEPDIR)/compile_options.Tpo"; exit 1; fi
diff --git a/libgfortran/config.h.in b/libgfortran/config.h.in
index ab7a8920713..216adba6e82 100644
--- a/libgfortran/config.h.in
+++ b/libgfortran/config.h.in
@@ -81,6 +81,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
 
@@ -171,6 +177,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
 
@@ -261,6 +270,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
 
@@ -279,9 +291,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
 
@@ -300,6 +318,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
 
@@ -372,15 +393,15 @@
 /* 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
 
-/* Define to 1 if you have the `gettimeofday' function. */
-#undef HAVE_GETTIMEOFDAY
-
 /* libc includes getuid */
 #undef HAVE_GETUID
 
@@ -486,6 +507,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
 
@@ -567,6 +591,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
 
diff --git a/libgfortran/configure b/libgfortran/configure
index 5939bb3b8ec..3ef0bed4abf 100755
--- a/libgfortran/configure
+++ b/libgfortran/configure
@@ -6575,7 +6575,8 @@ done
 
 
 
-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
@@ -10398,7 +10399,122 @@ done
 
 
 
-for ac_func in wait setmode getrlimit gettimeofday
+
+
+
+
+
+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
+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 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
@@ -10727,6 +10843,83 @@ _ACEOF
 
 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
diff --git a/libgfortran/configure.ac b/libgfortran/configure.ac
index 8711134d480..256a631f778 100644
--- a/libgfortran/configure.ac
+++ b/libgfortran/configure.ac
@@ -164,7 +164,7 @@ AC_HEADER_TIME
 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)
 
@@ -176,7 +176,10 @@ AC_CHECK_MEMBERS([struct stat.st_rdev])
 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 getrlimit gettimeofday)
+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])
@@ -184,6 +187,7 @@ 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
diff --git a/libgfortran/fmain.c b/libgfortran/fmain.c
index ec621256df1..397f17bdcf5 100644
--- a/libgfortran/fmain.c
+++ b/libgfortran/fmain.c
@@ -10,9 +10,13 @@ void MAIN__ (void);
 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__ ();
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index 80698e94422..3703949d17a 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -361,7 +361,7 @@ typedef struct
   int fpu_round, fpu_precision, fpe;
 
   int sighup, sigint;
-  int dump_core;
+  int dump_core, backtrace;
 }
 options_t;
 
@@ -378,6 +378,7 @@ typedef struct
   int pedantic;
   int convert;
   int dump_core;
+  int backtrace;
   size_t record_marker;
   int max_subrecord_length;
 }
@@ -550,6 +551,17 @@ export_proto(set_args);
 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)
diff --git a/libgfortran/runtime/backtrace.c b/libgfortran/runtime/backtrace.c
new file mode 100644
index 00000000000..3b17a3950bf
--- /dev/null
+++ b/libgfortran/runtime/backtrace.c
@@ -0,0 +1,333 @@
+/* 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);
+#else
+	st_printf ("  unable to produce a backtrace, sorry!\n");
+#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
+}
diff --git a/libgfortran/runtime/compile_options.c b/libgfortran/runtime/compile_options.c
index 06ebc4d9023..dc404da7b53 100644
--- a/libgfortran/runtime/compile_options.c
+++ b/libgfortran/runtime/compile_options.c
@@ -38,18 +38,20 @@ compile_options_t compile_options;
 
 /* Prototypes */
 extern void set_std (GFC_INTEGER_4, 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 dump_core)
+	 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;
 }
 
 
@@ -64,6 +66,7 @@ init_compile_options (void)
     | 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 = 0;
 }
 
 /* Function called by the front-end to tell us the
diff --git a/libgfortran/runtime/environ.c b/libgfortran/runtime/environ.c
index cc3be215c36..c9c1e27f3a2 100644
--- a/libgfortran/runtime/environ.c
+++ b/libgfortran/runtime/environ.c
@@ -542,6 +542,10 @@ static variable variable_table[] = {
     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}
 };
 
diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c
index afd6a217269..93b81c10721 100644
--- a/libgfortran/runtime/error.c
+++ b/libgfortran/runtime/error.c
@@ -71,6 +71,12 @@ Boston, MA 02110-1301, USA.  */
 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
diff --git a/libgfortran/runtime/main.c b/libgfortran/runtime/main.c
index cfd77f29be9..76e4aef724c 100644
--- a/libgfortran/runtime/main.c
+++ b/libgfortran/runtime/main.c
@@ -32,9 +32,15 @@ Boston, MA 02110-1301, USA.  */
 #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 @@ get_args (int *argc, char ***argv)
 }
 
 
+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))