summaryrefslogtreecommitdiff
path: root/libgfortran/runtime/error.c
diff options
context:
space:
mode:
Diffstat (limited to 'libgfortran/runtime/error.c')
-rw-r--r--libgfortran/runtime/error.c544
1 files changed, 544 insertions, 0 deletions
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
+<http://www.gnu.org/licenses/>. */
+
+
+#include "libgfortran.h"
+#include <assert.h>
+#include <string.h>
+#include <errno.h>
+
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#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
+
+
+#ifdef __MINGW32__
+#define HAVE_GETPID 1
+#include <process.h>
+#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;
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-17 07:10:01 +0000