From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- libgfortran/runtime/error.c | 544 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 544 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 000000000..06c144ae1 --- /dev/null +++ b/libgfortran/runtime/error.c @@ -0,0 +1,544 @@ +/* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009, 2010, 2011 + Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of the GNU Fortran 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 3, or (at your option) +any later version. + +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. + +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 +. */ + + +#include "libgfortran.h" +#include +#include +#include + +#ifdef HAVE_SIGNAL_H +#include +#endif + +#ifdef HAVE_UNISTD_H +#include +#endif + +#ifdef HAVE_STDLIB_H +#include +#endif + +#ifdef HAVE_SYS_TIME_H +#include +#endif + +/* has to be included before to work + around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */ +#ifdef HAVE_SYS_RESOURCE_H +#include +#endif + + +#ifdef __MINGW32__ +#define HAVE_GETPID 1 +#include +#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 + * 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. */ + +const char * +gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) +{ + int digit; + char *p; + + assert (len >= GFC_XTOA_BUF_SIZE); + + if (n == 0) + return "0"; + + p = buffer + GFC_XTOA_BUF_SIZE - 1; + *p = '\0'; + + while (n != 0) + { + digit = n & 0xF; + if (digit > 9) + digit += 'A' - '0' - 10; + + *--p = '0' + digit; + n >>= 4; + } + + return p; +} + + +/* Hopefully thread-safe wrapper for a strerror_r() style function. */ + +char * +gf_strerror (int errnum, + char * buf __attribute__((unused)), + size_t buflen __attribute__((unused))) +{ +#ifdef HAVE_STRERROR_R + /* TODO: How to prevent the compiler warning due to strerror_r of + the untaken branch having the wrong return type? */ + if (__builtin_classify_type (strerror_r (0, buf, 0)) == 5) + { + /* GNU strerror_r() */ + return strerror_r (errnum, buf, buflen); + } + else + { + /* POSIX strerror_r () */ + strerror_r (errnum, buf, buflen); + return buf; + } +#else + /* strerror () is not necessarily thread-safe, but should at least + be available everywhere. */ + return strerror (errnum); +#endif +} + + +/* show_locus()-- Print a line number and filename describing where + * something went wrong */ + +void +show_locus (st_parameter_common *cmp) +{ + static char *filename; + + if (!options.locus || cmp == NULL || cmp->filename == NULL) + return; + + if (cmp->unit > 0) + { + filename = filename_from_unit (cmp->unit); + if (filename != NULL) + { + st_printf ("At line %d of file %s (unit = %d, file = '%s')\n", + (int) cmp->line, cmp->filename, (int) cmp->unit, filename); + free (filename); + } + else + { + st_printf ("At line %d of file %s (unit = %d)\n", + (int) cmp->line, cmp->filename, (int) cmp->unit); + } + return; + } + + st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->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; + + /* Don't even try to print something at this point */ + if (magic == MAGIC) + sys_exit (4); + + magic = MAGIC; +} + + +#define STRERR_MAXSZ 256 + +/* 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) +{ + char errmsg[STRERR_MAXSZ]; + recursion_check (); + st_printf ("Operating system error: %s\n%s\n", + gf_strerror (errno, errmsg, STRERR_MAXSZ), 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, ...) +{ + va_list ap; + + recursion_check (); + 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. */ + +void +internal_error (st_parameter_common *cmp, const char *message) +{ + recursion_check (); + 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); +} + + +/* 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 LIBERROR_EOR: + p = "End of record"; + break; + + case LIBERROR_END: + p = "End of file"; + break; + + case LIBERROR_OK: + p = "Successful return"; + break; + + case LIBERROR_OS: + p = "Operating system error"; + break; + + case LIBERROR_BAD_OPTION: + p = "Bad statement option"; + break; + + case LIBERROR_MISSING_OPTION: + p = "Missing statement option"; + break; + + case LIBERROR_OPTION_CONFLICT: + p = "Conflicting statement options"; + break; + + case LIBERROR_ALREADY_OPEN: + p = "File already opened in another unit"; + break; + + case LIBERROR_BAD_UNIT: + p = "Unattached unit"; + break; + + case LIBERROR_FORMAT: + p = "FORMAT error"; + break; + + case LIBERROR_BAD_ACTION: + p = "Incorrect ACTION specified"; + break; + + case LIBERROR_ENDFILE: + p = "Read past ENDFILE record"; + break; + + case LIBERROR_BAD_US: + p = "Corrupt unformatted sequential file"; + break; + + case LIBERROR_READ_VALUE: + p = "Bad value during read"; + break; + + case LIBERROR_READ_OVERFLOW: + p = "Numeric overflow on read"; + break; + + 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: + 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 or IOMSG variable exists, we set it. If IOSTAT or + * ERR labels are present, we return, otherwise we terminate the program + * after printing 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 (st_parameter_common *cmp, int family, const char *message) +{ + char errmsg[STRERR_MAXSZ]; + + /* 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 == LIBERROR_OS) ? errno : family; + + if (message == NULL) + message = + (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) : + translate_error (family); + + 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 LIBERROR_EOR: + cmp->flags |= IOPARM_LIBRETURN_EOR; + if ((cmp->flags & IOPARM_EOR)) + return; + break; + + case LIBERROR_END: + cmp->flags |= IOPARM_LIBRETURN_END; + if ((cmp->flags & IOPARM_END)) + return; + break; + + default: + cmp->flags |= IOPARM_LIBRETURN_ERROR; + if ((cmp->flags & IOPARM_ERR)) + return; + break; + } + + /* Return if the user supplied an iostat variable. */ + if ((cmp->flags & IOPARM_HAS_IOSTAT)) + return; + + /* Terminate the program */ + + recursion_check (); + show_locus (cmp); + st_printf ("Fortran runtime error: %s\n", message); + sys_exit (2); +} +iexport(generate_error); + + +/* generate_warning()-- Similar to generate_error but just give a warning. */ + +void +generate_warning (st_parameter_common *cmp, const char *message) +{ + if (message == NULL) + message = " "; + + show_locus (cmp); + st_printf ("Fortran runtime warning: %s\n", 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 NOTIFICATION_SILENT; + + warning = compile_options.warn_std & std; + if ((compile_options.allow_std & std) != 0 && !warning) + return NOTIFICATION_SILENT; + + return warning ? NOTIFICATION_WARNING : NOTIFICATION_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 (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; + + if (!warning) + { + recursion_check (); + show_locus (cmp); + st_printf ("Fortran runtime error: %s\n", message); + sys_exit (2); + } + else + { + show_locus (cmp); + st_printf ("Fortran runtime warning: %s\n", message); + } + return FAILURE; +} -- cgit v1.2.3