1 /* Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public License
26 along with libgfortran; see the file COPYING. If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA. */
51 #ifdef HAVE_SYS_TIME_H
55 /* <sys/time.h> has to be included before <sys/resource.h> to work
56 around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */
57 #ifdef HAVE_SYS_RESOURCE_H
58 #include <sys/resource.h>
61 #include "libgfortran.h"
69 /* sys_exit()-- Terminate the program with an exit code. */
74 /* Show error backtrace if possible. */
75 if (code != 0 && code != 4
76 && (options.backtrace == 1
77 || (options.backtrace == -1 && compile_options.backtrace == 1)))
80 /* Dump core if requested. */
82 && (options.dump_core == 1
83 || (options.dump_core == -1 && compile_options.dump_core == 1)))
85 #if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
86 /* Warn if a core file cannot be produced because
87 of core size limit. */
89 struct rlimit core_limit;
91 if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0)
92 st_printf ("** Warning: a core dump was requested, but the core size"
93 "limit\n** is currently zero.\n\n");
97 #if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
98 kill (getpid (), SIGQUIT);
100 st_printf ("Core dump not possible, sorry.");
108 /* Error conditions. The tricky part here is printing a message when
109 * it is the I/O subsystem that is severely wounded. Our goal is to
110 * try and print something making the fewest assumptions possible,
111 * then try to clean up before actually exiting.
113 * The following exit conditions are defined:
114 * 0 Normal program exit.
115 * 1 Terminated because of operating system error.
116 * 2 Error in the runtime library
117 * 3 Internal error in runtime library
118 * 4 Error during error processing (very bad)
120 * Other error returns are reserved for the STOP statement with a numeric code.
123 /* gfc_itoa()-- Integer to decimal conversion. */
126 gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
130 GFC_UINTEGER_LARGEST t;
132 assert (len >= GFC_ITOA_BUF_SIZE);
142 t = -n; /*must use unsigned to protect from overflow*/
145 p = buffer + GFC_ITOA_BUF_SIZE - 1;
150 *--p = '0' + (t % 10);
160 /* xtoa()-- Integer to hexadecimal conversion. */
163 xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
168 assert (len >= GFC_XTOA_BUF_SIZE);
173 p = buffer + GFC_XTOA_BUF_SIZE - 1;
180 digit += 'A' - '0' - 10;
190 /* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
193 st_sprintf (char *buffer, const char *format, ...)
199 char itoa_buf[GFC_ITOA_BUF_SIZE];
201 va_start (arg, format);
218 *buffer++ = (char) va_arg (arg, int);
222 p = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf));
225 memcpy (buffer, p, count);
230 p = va_arg (arg, char *);
233 memcpy (buffer, p, count);
246 /* show_locus()-- Print a line number and filename describing where
247 * something went wrong */
250 show_locus (st_parameter_common *cmp)
252 if (!options.locus || cmp == NULL || cmp->filename == NULL)
255 st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
259 /* recursion_check()-- It's possible for additional errors to occur
260 * during fatal error processing. We detect this condition here and
261 * exit with code 4 immediately. */
263 #define MAGIC 0x20DE8101
266 recursion_check (void)
268 static int magic = 0;
270 /* Don't even try to print something at this point */
278 /* os_error()-- Operating system error. We get a message from the
279 * operating system, show it and leave. Some operating system errors
280 * are caught and processed by the library. If not, we come here. */
283 os_error (const char *message)
286 st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
291 /* void runtime_error()-- These are errors associated with an
292 * invalid fortran program. */
295 runtime_error (const char *message)
298 st_printf ("Fortran runtime error: %s\n", message);
301 iexport(runtime_error);
304 /* void internal_error()-- These are this-can't-happen errors
305 * that indicate something deeply wrong. */
308 internal_error (st_parameter_common *cmp, const char *message)
312 st_printf ("Internal Error: %s\n", message);
314 /* This function call is here to get the main.o object file included
315 when linking statically. This works because error.o is supposed to
316 be always linked in (and the function call is in internal_error
317 because hopefully it doesn't happen too often). */
318 stupid_function_name_for_static_linking();
324 /* translate_error()-- Given an integer error code, return a string
325 * describing the error. */
328 translate_error (int code)
343 p = "Successful return";
347 p = "Operating system error";
350 case ERROR_BAD_OPTION:
351 p = "Bad statement option";
354 case ERROR_MISSING_OPTION:
355 p = "Missing statement option";
358 case ERROR_OPTION_CONFLICT:
359 p = "Conflicting statement options";
362 case ERROR_ALREADY_OPEN:
363 p = "File already opened in another unit";
367 p = "Unattached unit";
374 case ERROR_BAD_ACTION:
375 p = "Incorrect ACTION specified";
379 p = "Read past ENDFILE record";
383 p = "Corrupt unformatted sequential file";
386 case ERROR_READ_VALUE:
387 p = "Bad value during read";
390 case ERROR_READ_OVERFLOW:
391 p = "Numeric overflow on read";
395 p = "Internal error in run-time library";
398 case ERROR_INTERNAL_UNIT:
399 p = "Internal unit I/O error";
402 case ERROR_DIRECT_EOR:
403 p = "Write exceeds length of DIRECT access record";
406 case ERROR_SHORT_RECORD:
407 p = "I/O past end of record on unformatted file";
410 case ERROR_CORRUPT_FILE:
411 p = "Unformatted file structure has been corrupted";
415 p = "Unknown error code";
423 /* generate_error()-- Come here when an error happens. This
424 * subroutine is called if it is possible to continue on after the error.
425 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
426 * ERR labels are present, we return, otherwise we terminate the program
427 * after printing a message. The error code is always required but the
428 * message parameter can be NULL, in which case a string describing
429 * the most recent operating system error is used. */
432 generate_error (st_parameter_common *cmp, int family, const char *message)
434 /* Set the error status. */
435 if ((cmp->flags & IOPARM_HAS_IOSTAT))
436 *cmp->iostat = (family == ERROR_OS) ? errno : family;
440 (family == ERROR_OS) ? get_oserror () : translate_error (family);
442 if (cmp->flags & IOPARM_HAS_IOMSG)
443 cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
445 /* Report status back to the compiler. */
446 cmp->flags &= ~IOPARM_LIBRETURN_MASK;
450 cmp->flags |= IOPARM_LIBRETURN_EOR;
451 if ((cmp->flags & IOPARM_EOR))
456 cmp->flags |= IOPARM_LIBRETURN_END;
457 if ((cmp->flags & IOPARM_END))
462 cmp->flags |= IOPARM_LIBRETURN_ERROR;
463 if ((cmp->flags & IOPARM_ERR))
468 /* Return if the user supplied an iostat variable. */
469 if ((cmp->flags & IOPARM_HAS_IOSTAT))
472 /* Terminate the program */
476 st_printf ("Fortran runtime error: %s\n", message);
481 /* Whether, for a feature included in a given standard set (GFC_STD_*),
482 we should issue an error or a warning, or be quiet. */
485 notification_std (int std)
489 if (!compile_options.pedantic)
492 warning = compile_options.warn_std & std;
493 if ((compile_options.allow_std & std) != 0 && !warning)
496 return warning ? WARNING : ERROR;
501 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
502 feature. An error/warning will be issued if the currently selected
503 standard does not contain the requested bits. */
506 notify_std (st_parameter_common *cmp, int std, const char * message)
510 if (!compile_options.pedantic)
513 warning = compile_options.warn_std & std;
514 if ((compile_options.allow_std & std) != 0 && !warning)
521 st_printf ("Fortran runtime error: %s\n", message);
527 st_printf ("Fortran runtime warning: %s\n", message);