-/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
#include <stdarg.h>
#include <string.h>
#include <float.h>
+#include <errno.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
* Other error returns are reserved for the STOP statement with a numeric code.
*/
-/* 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. */
-
-char *filename = 0;
-iexport_data(filename);
-
-unsigned line = 0;
-iexport_data(line);
-
/* gfc_itoa()-- Integer to decimal conversion. */
const char *
}
-/* 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];
-
- 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), 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
* something went wrong */
void
-show_locus (void)
+show_locus (st_parameter_common *cmp)
{
- if (!options.locus || filename == NULL)
+ if (!options.locus || cmp == NULL || cmp->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);
}
os_error (const char *message)
{
recursion_check ();
- show_locus ();
st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
sys_exit (1);
}
runtime_error (const char *message)
{
recursion_check ();
- show_locus ();
st_printf ("Fortran runtime error: %s\n", message);
sys_exit (2);
}
* that indicate something deeply wrong. */
void
-internal_error (const char *message)
+internal_error (st_parameter_common *cmp, const char *message)
{
recursion_check ();
- show_locus ();
+ show_locus (cmp);
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);
}
p = "Numeric overflow on read";
break;
- case ERROR_ARRAY_STRIDE:
- p = "Array unit stride must be 1";
+ case ERROR_INTERNAL:
+ p = "Internal error in run-time library";
+ break;
+
+ case ERROR_INTERNAL_UNIT:
+ 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:
* 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)
{
/* Set the error status. */
- if (ioparm.iostat != NULL)
- *ioparm.iostat = family;
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
+ *cmp->iostat = (family == ERROR_OS) ? errno : family;
if (message == NULL)
message =
(family == ERROR_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. */
+ cmp->flags &= ~IOPARM_LIBRETURN_MASK;
switch (family)
{
case ERROR_EOR:
- ioparm.library_return = LIBRARY_EOR;
- if (ioparm.eor != 0)
+ cmp->flags |= IOPARM_LIBRETURN_EOR;
+ if ((cmp->flags & IOPARM_EOR))
return;
break;
case ERROR_END:
- ioparm.library_return = LIBRARY_END;
- if (ioparm.end != 0)
+ cmp->flags |= IOPARM_LIBRETURN_END;
+ if ((cmp->flags & IOPARM_END))
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. */
- if (ioparm.iostat != NULL)
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
return;
/* Terminate the program */
- runtime_error (message);
+ recursion_check ();
+ show_locus (cmp);
+ st_printf ("Fortran runtime error: %s\n", message);
+ sys_exit (2);
+}
+
+
+/* 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;
}
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;
+ if (!compile_options.pedantic)
+ return SUCCESS;
+
warning = compile_options.warn_std & std;
if ((compile_options.allow_std & std) != 0 && !warning)
return SUCCESS;
- show_locus ();
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;
}
OSDN Git Service
