2009-10-14 Ramakrishna Upadrasta <Ramakrishna.Upadrasta@inria.fr>

[pf3gnuchains/gcc-fork.git] / libgfortran / runtime / error.c

diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c
index 7c708e3..07da6df 100644 (file)
--- a/libgfortran/runtime/error.c
+++ b/libgfortran/runtime/error.c
@@ -1,129 +1,132 @@
-/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009
+   Free Software Foundation, Inc.

    Contributed by Andy Vaught
 
 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
    Contributed by Andy Vaught
 
 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)
+the Free Software Foundation; either version 3, or (at your option)

 any later version.
 
 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.
 
 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.  */
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.

 
 

+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */

 
 

-#include "config.h"
-#include <stdio.h>
-#include <stdarg.h>
-#include <string.h>
-#include <float.h>

 
 #include "libgfortran.h"
 
 #include "libgfortran.h"

-#include "../io/io.h"
-
-/* 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,
- * then try to clean up before actually exiting.
- *
- * The following exit conditions are defined:
- * 0    Normal program exit.
- * 1    Terminated because of operating system error.
- * 2    Error in the runtime library
- * 3    Internal error in runtime library
- * 4    Error during error processing (very bad)
- *
- * Other error returns are reserved for the STOP statement with a numeric code.
- */
+#include <assert.h>
+#include <string.h>
+#include <errno.h>

 
 

-/* locus variables.  These are optionally set by a caller before a
- * library subroutine is called.  They are always cleared on exit so
- * that files that report loci and those that do not can be linked
- * together without reporting an erroneous position. */
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif

 
 

-char *filename = 0;
-iexport_data(filename);
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif

 
 

-unsigned line = 0;
-iexport_data(line);
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif

 
 

-/* buffer for integer/ascii conversions.  */
-static char buffer[sizeof (GFC_UINTEGER_LARGEST) * 8 + 1];
+#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

 
 

-/* Returns a pointer to a static buffer. */

 
 

-char *
-gfc_itoa (GFC_INTEGER_LARGEST n)
-{
-  int negative;
-  char *p;
-  GFC_UINTEGER_LARGEST t;
+#ifdef __MINGW32__
+#define HAVE_GETPID 1
+#include <process.h>
+#endif

 
 

-  if (n == 0)
-    {
-      buffer[0] = '0';
-      buffer[1] = '\0';
-      return buffer;
-    }
-
-  negative = 0;
-  t = n;
-  if (n < 0)
-    {
-      negative = 1;
-      t = -n; /*must use unsigned to protect from overflow*/
-    }

 
 

-  p = buffer + sizeof (buffer) - 1;
-  *p-- = '\0';
+/* sys_exit()-- Terminate the program with an exit code.  */

 
 

-  while (t != 0)
+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)))

     {
     {

-      *p-- = '0' + (t % 10);
-      t /= 10;
+#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

     }
 
     }
 

-  if (negative)
-    *p-- = '-';
-  return ++p;
+  exit (code);

 }
 
 
 }
 
 

-/* xtoa()-- Integer to hexadecimal conversion.  Returns a pointer to a
- * static buffer. */
+/* 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,
+ * then try to clean up before actually exiting.
+ *
+ * The following exit conditions are defined:
+ * 0    Normal program exit.
+ * 1    Terminated because of operating system error.
+ * 2    Error in the runtime library
+ * 3    Internal error in runtime library
+ * 4    Error during error processing (very bad)
+ *
+ * Other error returns are reserved for the STOP statement with a numeric code.
+ */
+
+/* gfc_xtoa()-- Integer to hexadecimal conversion.  */

 
 

-char *
-xtoa (GFC_UINTEGER_LARGEST n)
+const char *
+gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)

 {
   int digit;
   char *p;
 
 {
   int digit;
   char *p;
 

+  assert (len >= GFC_XTOA_BUF_SIZE);
+

   if (n == 0)
   if (n == 0)

-    {
-      buffer[0] = '0';
-      buffer[1] = '\0';
-      return buffer;
-    }
+    return "0";

 
 

-  p = buffer + sizeof (buffer) - 1;
-  *p-- = '\0';
+  p = buffer + GFC_XTOA_BUF_SIZE - 1;
+  *p = '\0';

 
   while (n != 0)
     {
 
   while (n != 0)
     {


@@ -131,173 +134,42 @@ xtoa (GFC_UINTEGER_LARGEST n)
       if (digit > 9)
        digit += 'A' - '0' - 10;
 
       if (digit > 9)
        digit += 'A' - '0' - 10;
 

-      *p-- = '0' + digit;
+      *--p = '0' + digit;

       n >>= 4;
     }
 
       n >>= 4;
     }
 

-  return ++p;
-}
-
-
-/* st_printf()-- simple printf() function for streams that handles the
- * formats %d, %s and %c.  This function handles printing of error
- * messages that originate within the library itself, not from a user
- * program. */
-
-int
-st_printf (const char *format, ...)
-{
-  int count, total;
-  va_list arg;
-  char *p, *q;
-  stream *s;
-
-  total = 0;
-  s = init_error_stream ();
-  va_start (arg, format);
-
-  for (;;)
-    {
-      count = 0;
-
-      while (format[count] != '%' && format[count] != '\0')
-       count++;
-
-      if (count != 0)
-       {
-         p = salloc_w (s, &count);
-         memmove (p, format, count);
-         sfree (s);
-       }
-
-      total += count;
-      format += count;
-      if (*format++ == '\0')
-       break;
-
-      switch (*format)
-       {
-       case 'c':
-         count = 1;
-
-         p = salloc_w (s, &count);
-         *p = (char) va_arg (arg, int);
-
-         sfree (s);
-         break;
-
-       case 'd':
-         q = gfc_itoa (va_arg (arg, int));
-         count = strlen (q);
-
-         p = salloc_w (s, &count);
-         memmove (p, q, count);
-         sfree (s);
-         break;
-
-       case 'x':
-         q = xtoa (va_arg (arg, unsigned));
-         count = strlen (q);
-
-         p = salloc_w (s, &count);
-         memmove (p, q, count);
-         sfree (s);
-         break;
-
-       case 's':
-         q = va_arg (arg, char *);
-         count = strlen (q);
-
-         p = salloc_w (s, &count);
-         memmove (p, q, count);
-         sfree (s);
-         break;
-
-       case '\0':
-         return total;
-
-       default:
-         count = 2;
-         p = salloc_w (s, &count);
-         p[0] = format[-1];
-         p[1] = format[0];
-         sfree (s);
-         break;
-       }
-
-      total += count;
-      format++;
-    }
-
-  va_end (arg);
-  return total;
+  return p;

 }
 
 }
 

-
-/* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
+/* show_locus()-- Print a line number and filename describing where
+ * something went wrong */

 
 void
 
 void

-st_sprintf (char *buffer, const char *format, ...)
+show_locus (st_parameter_common *cmp)

 {
 {

-  va_list arg;
-  char c, *p;
-  int count;
+  static char *filename;

 
 

-  va_start (arg, format);
-
-  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));
-         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 (void)
-{
-  if (!options.locus || filename == NULL)
-    return;
-
-  st_printf ("At line %d of file %s\n", line, filename);
+  st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);

 }
 
 
 }
 
 


@@ -328,35 +200,81 @@ void
 os_error (const char *message)
 {
   recursion_check ();
 os_error (const char *message)
 {
   recursion_check ();

-  show_locus ();

   st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
   sys_exit (1);
 }
   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
 
 
 /* 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 ();
   recursion_check ();

-  show_locus ();
-  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);
 
   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. */
 
 void
 
 /* void internal_error()-- These are this-can't-happen errors
  * that indicate something deeply wrong. */
 
 void

-internal_error (const char *message)
+internal_error (st_parameter_common *cmp, const char *message)

 {
   recursion_check ();
 {
   recursion_check ();

-  show_locus ();
+  show_locus (cmp);

   st_printf ("Internal Error: %s\n", message);
   st_printf ("Internal Error: %s\n", message);

+
+  /* This function call is here to get the main.o object file included
+     when linking statically. This works because error.o is supposed to
+     be always linked in (and the function call is in internal_error
+     because hopefully it doesn't happen too often).  */
+  stupid_function_name_for_static_linking();
+

   sys_exit (3);
 }
 
   sys_exit (3);
 }
 


@@ -371,68 +289,84 @@ translate_error (int code)
 
   switch (code)
     {
 
   switch (code)
     {

-    case ERROR_EOR:
+    case LIBERROR_EOR:

       p = "End of record";
       break;
 
       p = "End of record";
       break;
 

-    case ERROR_END:
+    case LIBERROR_END:

       p = "End of file";
       break;
 
       p = "End of file";
       break;
 

-    case ERROR_OK:
+    case LIBERROR_OK:

       p = "Successful return";
       break;
 
       p = "Successful return";
       break;
 

-    case ERROR_OS:
+    case LIBERROR_OS:

       p = "Operating system error";
       break;
 
       p = "Operating system error";
       break;
 

-    case ERROR_BAD_OPTION:
+    case LIBERROR_BAD_OPTION:

       p = "Bad statement option";
       break;
 
       p = "Bad statement option";
       break;
 

-    case ERROR_MISSING_OPTION:
+    case LIBERROR_MISSING_OPTION:

       p = "Missing statement option";
       break;
 
       p = "Missing statement option";
       break;
 

-    case ERROR_OPTION_CONFLICT:
+    case LIBERROR_OPTION_CONFLICT:

       p = "Conflicting statement options";
       break;
 
       p = "Conflicting statement options";
       break;
 

-    case ERROR_ALREADY_OPEN:
+    case LIBERROR_ALREADY_OPEN:

       p = "File already opened in another unit";
       break;
 
       p = "File already opened in another unit";
       break;
 

-    case ERROR_BAD_UNIT:
+    case LIBERROR_BAD_UNIT:

       p = "Unattached unit";
       break;
 
       p = "Unattached unit";
       break;
 

-    case ERROR_FORMAT:
+    case LIBERROR_FORMAT:

       p = "FORMAT error";
       break;
 
       p = "FORMAT error";
       break;
 

-    case ERROR_BAD_ACTION:
+    case LIBERROR_BAD_ACTION:

       p = "Incorrect ACTION specified";
       break;
 
       p = "Incorrect ACTION specified";
       break;
 

-    case ERROR_ENDFILE:
+    case LIBERROR_ENDFILE:

       p = "Read past ENDFILE record";
       break;
 
       p = "Read past ENDFILE record";
       break;
 

-    case ERROR_BAD_US:
+    case LIBERROR_BAD_US:

       p = "Corrupt unformatted sequential file";
       break;
 
       p = "Corrupt unformatted sequential file";
       break;
 

-    case ERROR_READ_VALUE:
+    case LIBERROR_READ_VALUE:

       p = "Bad value during read";
       break;
 
       p = "Bad value during read";
       break;
 

-    case ERROR_READ_OVERFLOW:
+    case LIBERROR_READ_OVERFLOW:

       p = "Numeric overflow on read";
       break;
 
       p = "Numeric overflow on read";
       break;
 

-    case ERROR_ARRAY_STRIDE:
-      p = "Array unit stride must be 1";
+    case LIBERROR_INTERNAL:
+      p = "Internal error in run-time library";
+      break;
+
+    case LIBERROR_INTERNAL_UNIT:
+      p = "Internal unit I/O error";
+      break;
+
+    case LIBERROR_DIRECT_EOR:
+      p = "Write exceeds length of DIRECT access record";
+      break;
+
+    case LIBERROR_SHORT_RECORD:
+      p = "I/O past end of record on unformatted file";
+      break;
+
+    case LIBERROR_CORRUPT_FILE:
+      p = "Unformatted file structure has been corrupted";

       break;
 
     default:
       break;
 
     default:


@@ -453,48 +387,78 @@ translate_error (int code)
  * the most recent operating system error is used. */
 
 void
  * the most recent operating system error is used. */
 
 void

-generate_error (int family, const char *message)
+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.  */
   /* Set the error status.  */

-  if (ioparm.iostat != NULL)
-    *ioparm.iostat = family;
+  if ((cmp->flags & IOPARM_HAS_IOSTAT))
+    *cmp->iostat = (family == LIBERROR_OS) ? errno : family;

 
   if (message == NULL)
     message =
 
   if (message == NULL)
     message =

-      (family == ERROR_OS) ? get_oserror () : translate_error (family);
+      (family == LIBERROR_OS) ? get_oserror () : translate_error (family);

 
 

-  if (ioparm.iomsg)
-    cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message);
+  if (cmp->flags & IOPARM_HAS_IOMSG)
+    cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);

 
   /* Report status back to the compiler.  */
 
   /* Report status back to the compiler.  */

+  cmp->flags &= ~IOPARM_LIBRETURN_MASK;

   switch (family)
     {
   switch (family)
     {

-    case ERROR_EOR:
-      ioparm.library_return = LIBRARY_EOR;
-      if (ioparm.eor != 0)
+    case LIBERROR_EOR:
+      cmp->flags |= IOPARM_LIBRETURN_EOR;
+      if ((cmp->flags & IOPARM_EOR))

        return;
       break;
 
        return;
       break;
 

-    case ERROR_END:
-      ioparm.library_return = LIBRARY_END;
-      if (ioparm.end != 0)
+    case LIBERROR_END:
+      cmp->flags |= IOPARM_LIBRETURN_END;
+      if ((cmp->flags & IOPARM_END))

        return;
       break;
 
     default:
        return;
       break;
 
     default:

-      ioparm.library_return = LIBRARY_ERROR;
-      if (ioparm.err != 0)
+      cmp->flags |= IOPARM_LIBRETURN_ERROR;
+      if ((cmp->flags & IOPARM_ERR))

        return;
       break;
     }
 
   /* Return if the user supplied an iostat variable.  */
        return;
       break;
     }
 
   /* Return if the user supplied an iostat variable.  */

-  if (ioparm.iostat != NULL)
+  if ((cmp->flags & IOPARM_HAS_IOSTAT))

     return;
 
   /* Terminate the program */
 
     return;
 
   /* Terminate the program */
 

-  runtime_error (message);
+  recursion_check ();
+  show_locus (cmp);
+  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.  */
+
+notification
+notification_std (int std)
+{
+  int warning;
+
+  if (!compile_options.pedantic)
+    return SILENT;
+
+  warning = compile_options.warn_std & std;
+  if ((compile_options.allow_std & std) != 0 && !warning)
+    return SILENT;
+
+  return warning ? WARNING : ERROR;

 }
 
 
 }
 
 


@@ -504,21 +468,28 @@ generate_error (int family, const char *message)
    standard does not contain the requested bits.  */
 
 try
    standard does not contain the requested bits.  */
 
 try

-notify_std (int std, const char * message)
+notify_std (st_parameter_common *cmp, int std, const char * message)

 {
   int warning;
 
 {
   int warning;
 

+  if (!compile_options.pedantic)
+    return SUCCESS;
+

   warning = compile_options.warn_std & std;
   if ((compile_options.allow_std & std) != 0 && !warning)
     return SUCCESS;
 
   warning = compile_options.warn_std & std;
   if ((compile_options.allow_std & std) != 0 && !warning)
     return SUCCESS;
 

-  show_locus ();

   if (!warning)
     {
   if (!warning)
     {

+      recursion_check ();
+      show_locus (cmp);

       st_printf ("Fortran runtime error: %s\n", message);
       sys_exit (2);
     }
   else
       st_printf ("Fortran runtime error: %s\n", message);
       sys_exit (2);
     }
   else

-    st_printf ("Fortran runtime warning: %s\n", message);
+    {
+      show_locus (cmp);
+      st_printf ("Fortran runtime warning: %s\n", message);
+    }

   return FAILURE;
 }
   return FAILURE;
 }