From 4ee9c6840ad3fc92a9034343278a1e476ad6872a Mon Sep 17 00:00:00 2001 From: dnovillo Date: Thu, 13 May 2004 06:41:07 +0000 Subject: Merge tree-ssa-20020619-branch into mainline. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@81764 138bc75d-0d04-0410-961f-82ee72b054a4 --- libgfortran/runtime/error.c | 538 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 538 insertions(+) create mode 100644 libgfortran/runtime/error.c (limited to 'libgfortran/runtime/error.c') diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c new file mode 100644 index 00000000000..8cd980dff9a --- /dev/null +++ b/libgfortran/runtime/error.c @@ -0,0 +1,538 @@ +/* Copyright (C) 2002-2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor 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. + +Libgfor 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 libgfor; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include +#include +#include +#include + +#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. + */ + +/* 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; +unsigned line; + +static char buffer[32]; /* buffer for integer/ascii conversions */ + +/* rtoa()-- Real to ascii conversion for base 10 and below. + * Returns a pointer to a static buffer. */ + +char * +rtoa (double f, int length, int oprec) +{ + double n = f; + double fval, minval; + int negative, prec; + unsigned k; + char formats[16]; + + prec = 0; + negative = 0; + if (n < 0.0) + { + negative = 1; + n = -n; + } + + if (length >= 8) + minval = FLT_MIN; + else + minval = DBL_MIN; + + + if (n <= minval) + { + buffer[0] = '0'; + buffer[1] = '.'; + for (k = 2; k < 28 ; k++) + buffer[k] = '0'; + buffer[k+1] = '\0'; + return buffer; + } + fval = n; + while (fval > 1.0) + { + fval = fval / 10.0; + prec ++; + } + + prec = sizeof (buffer) - 2 - prec; + if (prec > 20) + prec = 20; + prec = prec > oprec ? oprec : prec ; + + if (negative) + sprintf (formats, "-%%.%df", prec); + else + sprintf (formats, "%%.%df", prec); + + sprintf (buffer, formats, n); + return buffer; +} + + +/* Returns a pointer to a static buffer. */ + +char * +itoa (int64_t n) +{ + int negative; + char *p; + + if (n == 0) + { + buffer[0] = '0'; + buffer[1] = '\0'; + return buffer; + } + + negative = 0; + if (n < 0) + { + negative = 1; + n = -n; + } + + p = buffer + sizeof (buffer) - 1; + *p-- = '\0'; + + while (n != 0) + { + *p-- = '0' + (n % 10); + n /= 10; + } + + if (negative) + *p-- = '-'; + return ++p; +} + + +/* xtoa()-- Integer to hexadecimal conversion. Returns a pointer to a + * static buffer. */ + +char * +xtoa (uint64_t n) +{ + int digit; + char *p; + + if (n == 0) + { + buffer[0] = '0'; + buffer[1] = '\0'; + return buffer; + } + + p = buffer + sizeof (buffer) - 1; + *p-- = '\0'; + + while (n != 0) + { + digit = n & 0xF; + if (digit > 9) + digit += 'A' - '0' - 10; + + *p-- = '0' + digit; + 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 = 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; +} + + +/* st_sprintf()-- Simple sprintf() for formatting memory buffers. */ + +void +st_sprintf (char *buffer, const char *format, ...) +{ + va_list arg; + char c, *p; + int count; + + va_start (arg, format); + + for (;;) + { + c = *format++; + if (c != '%') + { + *buffer++ = c; + if (c == '\0') + break; + continue; + } + + c = *format++; + switch (c) + { + case 'c': + *buffer++ = (char) va_arg (arg, int); + break; + + case 'd': + p = 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; + } + } + + 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); +} + + +/* recursion_check()-- It's possible for additional errors to occur + * during fatal error processing. We detect this condition here and + * exit with code 4 immediately. */ + +#define MAGIC 0x20DE8101 + +static void +recursion_check (void) +{ + static int magic = 0; + + if (magic == MAGIC) + sys_exit (4); /* Don't even try to print something at this point */ + + magic = MAGIC; +} + + +/* os_error()-- Operating system error. We get a message from the + * operating system, show it and leave. Some operating system errors + * are caught and processed by the library. If not, we come here. */ + +void +os_error (const char *message) +{ + + recursion_check (); + + show_locus (); + st_printf ("Operating system error: %s\n%s\n", get_oserror (), message); + + sys_exit (1); +} + + +/* void runtime_error()-- These are errors associated with an + * invalid fortran program. */ + +void +runtime_error (const char *message) +{ + + recursion_check (); + + show_locus (); + st_printf ("Fortran runtime error: %s\n", message); + + sys_exit (2); +} + + +/* void internal_error()-- These are this-can't-happen errors + * that indicate something deeply wrong. */ + +void +internal_error (const char *message) +{ + + recursion_check (); + + show_locus (); + st_printf ("Internal Error: %s\n", message); + sys_exit (3); +} + + +/* translate_error()-- Given an integer error code, return a string + * describing the error. */ + +const char * +translate_error (int code) +{ + const char *p; + + switch (code) + { + case ERROR_EOR: + p = "End of record"; + break; + + case ERROR_END: + p = "End of file"; + break; + + case ERROR_OK: + p = "Successful return"; + break; + + case ERROR_OS: + p = "Operating system error"; + break; + + case ERROR_BAD_OPTION: + p = "Bad statement option"; + break; + + case ERROR_MISSING_OPTION: + p = "Missing statement option"; + break; + + case ERROR_OPTION_CONFLICT: + p = "Conflicting statement options"; + break; + + case ERROR_ALREADY_OPEN: + p = "File already opened in another unit"; + break; + + case ERROR_BAD_UNIT: + p = "Unattached unit"; + break; + + case ERROR_FORMAT: + p = "FORMAT error"; + break; + + case ERROR_BAD_ACTION: + p = "Incorrect ACTION specified"; + break; + + case ERROR_ENDFILE: + p = "Read past ENDFILE record"; + break; + + case ERROR_BAD_US: + p = "Corrupt unformatted sequential file"; + break; + + case ERROR_READ_VALUE: + p = "Bad value during read"; + break; + + case ERROR_READ_OVERFLOW: + p = "Numeric overflow on read"; + break; + + default: + p = "Unknown error code"; + break; + } + + return p; +} + + +/* generate_error()-- Come here when an error happens. This + * subroutine is called if it is possible to continue on after the + * error. If an IOSTAT variable exists, we set it. If the IOSTAT or + * ERR label is present, we return, otherwise we terminate the program + * after print a message. The error code is always required but the + * message parameter can be NULL, in which case a string describing + * the most recent operating system error is used. */ + +void +generate_error (int family, const char *message) +{ + + if (ioparm.iostat != NULL) + { + *ioparm.iostat = family; + return; + } + + switch (family) + { + case ERROR_EOR: + ioparm.library_return = LIBRARY_EOR; + if (ioparm.eor != 0) + return; + break; + + case ERROR_END: + ioparm.library_return = LIBRARY_END; + if (ioparm.end != 0) + return; + break; + + default: + ioparm.library_return = LIBRARY_ERROR; + break; + } + + if (ioparm.err != 0) + return; + + /* Terminate the program */ + + if (message == NULL) + message = + (family == ERROR_OS) ? get_oserror () : translate_error (family); + + runtime_error (message); +} -- cgit v1.2.1