PR libfortran/27107

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

diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c
index b25cd0c..c0787de 100644 (file)
--- a/libgfortran/runtime/error.c
+++ b/libgfortran/runtime/error.c
@@ -34,10 +34,9 @@ Boston, MA 02110-1301, USA.  */
 #include <stdarg.h>
 #include <string.h>
 #include <float.h>
+#include <errno.h>
 
 #include "libgfortran.h"
-#include "../io/io.h"
-#include "../io/unix.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
@@ -121,104 +120,6 @@ xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 }
 
 
-/* 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;
-  const char *q;
-  stream *s;
-  char itoa_buf[GFC_ITOA_BUF_SIZE];
-  unix_stream err_stream;
-
-  total = 0;
-  s = init_error_stream (&err_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), itoa_buf, sizeof (itoa_buf));
-         count = strlen (q);
-
-         p = salloc_w (s, &count);
-         memmove (p, q, count);
-         sfree (s);
-         break;
-
-       case 'x':
-         q = xtoa (va_arg (arg, unsigned), itoa_buf, sizeof (itoa_buf));
-         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;
-}
-
-
 /* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
 
 void
@@ -284,7 +185,7 @@ show_locus (st_parameter_common *cmp)
   if (!options.locus || cmp == NULL || cmp->filename == NULL)
     return;
 
-  st_printf ("At line %d of file %s\n", cmp->line, cmp->filename);
+  st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
 }
 
 
@@ -431,6 +332,18 @@ translate_error (int code)
       p = "Internal unit I/O error";
       break;
 
+    case ERROR_DIRECT_EOR:
+      p = "Write exceeds length of DIRECT access record";
+      break;
+
+    case ERROR_SHORT_RECORD:
+      p = "I/O past end of record on unformatted file";
+      break;
+
+    case ERROR_CORRUPT_FILE:
+      p = "Unformatted file structure has been corrupted";
+      break;
+
     default:
       p = "Unknown error code";
       break;
@@ -453,7 +366,7 @@ generate_error (st_parameter_common *cmp, int family, const char *message)
 {
   /* Set the error status.  */
   if ((cmp->flags & IOPARM_HAS_IOSTAT))
-    *cmp->iostat = family;
+    *cmp->iostat = (family == ERROR_OS) ? errno : family;
 
   if (message == NULL)
     message =
@@ -498,13 +411,32 @@ generate_error (st_parameter_common *cmp, int family, const char *message)
 }
 
 
+/* 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;
+}
+
+
 
 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
    feature.  An error/warning will be issued if the currently selected
    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;
 
@@ -517,10 +449,15 @@ notify_std (int std, const char * message)
 
   if (!warning)
     {
+      recursion_check ();
+      show_locus (cmp);
       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;
 }