OSDN Git Service

PR c++/35297
[pf3gnuchains/gcc-fork.git] / libgfortran / runtime / error.c
index c0787de..d75eaf2 100644 (file)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005, 2006, 2007 Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -28,15 +28,78 @@ the Free Software Foundation, 51 Franklin Street, Fifth Floor,
 Boston, MA 02110-1301, USA.  */
 
 
-#include "config.h"
+#include "libgfortran.h"
 #include <assert.h>
-#include <stdio.h>
-#include <stdarg.h>
 #include <string.h>
-#include <float.h>
 #include <errno.h>
 
-#include "libgfortran.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_TIME_H
+#include <sys/time.h>
+#endif
+
+/* <sys/time.h> has to be included before <sys/resource.h> to work
+   around PR 30518; otherwise, MacOS 10.3.9 headers are just broken.  */
+#ifdef HAVE_SYS_RESOURCE_H
+#include <sys/resource.h>
+#endif
+
+
+#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
@@ -119,72 +182,34 @@ xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
   return p;
 }
 
-
-/* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
+/* show_locus()-- Print a line number and filename describing where
+ * something went wrong */
 
 void
-st_sprintf (char *buffer, const char *format, ...)
+show_locus (st_parameter_common *cmp)
 {
-  va_list arg;
-  char c;
-  const char *p;
-  int count;
-  char itoa_buf[GFC_ITOA_BUF_SIZE];
-
-  va_start (arg, format);
+  static char *filename;
 
-  for (;;)
+  if (!options.locus || cmp == NULL || cmp->filename == NULL)
+    return;
+  
+  if (cmp->unit > 0)
     {
-      c = *format++;
-      if (c != '%')
+      filename = filename_from_unit (cmp->unit);
+      if (filename != NULL)
        {
-         *buffer++ = c;
-         if (c == '\0')
-           break;
-         continue;
+         st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
+                  (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
+         free_mem (filename);
        }
-
-      c = *format++;
-      switch (c)
+      else
        {
-       case 'c':
-         *buffer++ = (char) va_arg (arg, int);
-         break;
-
-       case 'd':
-         p = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf));
-         count = strlen (p);
-
-         memcpy (buffer, p, count);
-         buffer += count;
-         break;
-
-       case 's':
-         p = va_arg (arg, char *);
-         count = strlen (p);
-
-         memcpy (buffer, p, count);
-         buffer += count;
-         break;
-
-       default:
-         *buffer++ = c;
+         st_printf ("At line %d of file %s (unit = %d)\n",
+                  (int) cmp->line, cmp->filename, (int) cmp->unit);
        }
+      return;
     }
 
-  va_end (arg);
-}
-
-
-/* show_locus()-- Print a line number and filename describing where
- * something went wrong */
-
-void
-show_locus (st_parameter_common *cmp)
-{
-  if (!options.locus || cmp == NULL || cmp->filename == NULL)
-    return;
-
   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
 }
 
@@ -219,20 +244,61 @@ os_error (const char *message)
   st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
   sys_exit (1);
 }
+iexport(os_error);
 
 
 /* void runtime_error()-- These are errors associated with an
  * invalid fortran program. */
 
 void
-runtime_error (const char *message)
+runtime_error (const char *message, ...)
 {
+  va_list ap;
+
   recursion_check ();
-  st_printf ("Fortran runtime error: %s\n", message);
+  st_printf ("Fortran runtime error: ");
+  va_start (ap, message);
+  st_vprintf (message, ap);
+  va_end (ap);
+  st_printf ("\n");
   sys_exit (2);
 }
 iexport(runtime_error);
 
+/* void runtime_error_at()-- These are errors associated with a
+ * run time error generated by the front end compiler.  */
+
+void
+runtime_error_at (const char *where, const char *message, ...)
+{
+  va_list ap;
+
+  recursion_check ();
+  st_printf ("%s\n", where);
+  st_printf ("Fortran runtime error: ");
+  va_start (ap, message);
+  st_vprintf (message, ap);
+  va_end (ap);
+  st_printf ("\n");
+  sys_exit (2);
+}
+iexport(runtime_error_at);
+
+
+void
+runtime_warning_at (const char *where, const char *message, ...)
+{
+  va_list ap;
+
+  st_printf ("%s\n", where);
+  st_printf ("Fortran runtime warning: ");
+  va_start (ap, message);
+  st_vprintf (message, ap);
+  va_end (ap);
+  st_printf ("\n");
+}
+iexport(runtime_warning_at);
+
 
 /* void internal_error()-- These are this-can't-happen errors
  * that indicate something deeply wrong. */
@@ -264,83 +330,83 @@ translate_error (int code)
 
   switch (code)
     {
-    case ERROR_EOR:
+    case LIBERROR_EOR:
       p = "End of record";
       break;
 
-    case ERROR_END:
+    case LIBERROR_END:
       p = "End of file";
       break;
 
-    case ERROR_OK:
+    case LIBERROR_OK:
       p = "Successful return";
       break;
 
-    case ERROR_OS:
+    case LIBERROR_OS:
       p = "Operating system error";
       break;
 
-    case ERROR_BAD_OPTION:
+    case LIBERROR_BAD_OPTION:
       p = "Bad statement option";
       break;
 
-    case ERROR_MISSING_OPTION:
+    case LIBERROR_MISSING_OPTION:
       p = "Missing statement option";
       break;
 
-    case ERROR_OPTION_CONFLICT:
+    case LIBERROR_OPTION_CONFLICT:
       p = "Conflicting statement options";
       break;
 
-    case ERROR_ALREADY_OPEN:
+    case LIBERROR_ALREADY_OPEN:
       p = "File already opened in another unit";
       break;
 
-    case ERROR_BAD_UNIT:
+    case LIBERROR_BAD_UNIT:
       p = "Unattached unit";
       break;
 
-    case ERROR_FORMAT:
+    case LIBERROR_FORMAT:
       p = "FORMAT error";
       break;
 
-    case ERROR_BAD_ACTION:
+    case LIBERROR_BAD_ACTION:
       p = "Incorrect ACTION specified";
       break;
 
-    case ERROR_ENDFILE:
+    case LIBERROR_ENDFILE:
       p = "Read past ENDFILE record";
       break;
 
-    case ERROR_BAD_US:
+    case LIBERROR_BAD_US:
       p = "Corrupt unformatted sequential file";
       break;
 
-    case ERROR_READ_VALUE:
+    case LIBERROR_READ_VALUE:
       p = "Bad value during read";
       break;
 
-    case ERROR_READ_OVERFLOW:
+    case LIBERROR_READ_OVERFLOW:
       p = "Numeric overflow on read";
       break;
 
-    case ERROR_INTERNAL:
+    case LIBERROR_INTERNAL:
       p = "Internal error in run-time library";
       break;
 
-    case ERROR_INTERNAL_UNIT:
+    case LIBERROR_INTERNAL_UNIT:
       p = "Internal unit I/O error";
       break;
 
-    case ERROR_DIRECT_EOR:
+    case LIBERROR_DIRECT_EOR:
       p = "Write exceeds length of DIRECT access record";
       break;
 
-    case ERROR_SHORT_RECORD:
+    case LIBERROR_SHORT_RECORD:
       p = "I/O past end of record on unformatted file";
       break;
 
-    case ERROR_CORRUPT_FILE:
+    case LIBERROR_CORRUPT_FILE:
       p = "Unformatted file structure has been corrupted";
       break;
 
@@ -364,13 +430,20 @@ translate_error (int code)
 void
 generate_error (st_parameter_common *cmp, int family, const char *message)
 {
+
+  /* If there was a previous error, don't mask it with another
+     error message, EOF or EOR condition.  */
+
+  if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
+    return;
+
   /* Set the error status.  */
   if ((cmp->flags & IOPARM_HAS_IOSTAT))
-    *cmp->iostat = (family == ERROR_OS) ? errno : family;
+    *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
 
   if (message == NULL)
     message =
-      (family == ERROR_OS) ? get_oserror () : translate_error (family);
+      (family == LIBERROR_OS) ? get_oserror () : translate_error (family);
 
   if (cmp->flags & IOPARM_HAS_IOMSG)
     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
@@ -379,13 +452,13 @@ generate_error (st_parameter_common *cmp, int family, const char *message)
   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
   switch (family)
     {
-    case ERROR_EOR:
+    case LIBERROR_EOR:
       cmp->flags |= IOPARM_LIBRETURN_EOR;
       if ((cmp->flags & IOPARM_EOR))
        return;
       break;
 
-    case ERROR_END:
+    case LIBERROR_END:
       cmp->flags |= IOPARM_LIBRETURN_END;
       if ((cmp->flags & IOPARM_END))
        return;
@@ -409,7 +482,7 @@ generate_error (st_parameter_common *cmp, int family, const char *message)
   st_printf ("Fortran runtime error: %s\n", message);
   sys_exit (2);
 }
-
+iexport(generate_error);
 
 /* Whether, for a feature included in a given standard set (GFC_STD_*),
    we should issue an error or a warning, or be quiet.  */