1 /* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009, 2010, 2011
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
27 #include "libgfortran.h"
44 #ifdef HAVE_SYS_TIME_H
48 /* <sys/time.h> has to be included before <sys/resource.h> to work
49 around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */
50 #ifdef HAVE_SYS_RESOURCE_H
51 #include <sys/resource.h>
61 /* sys_exit()-- Terminate the program with an exit code. */
66 /* Show error backtrace if possible. */
67 if (code != 0 && code != 4
68 && (options.backtrace == 1
69 || (options.backtrace == -1 && compile_options.backtrace == 1)))
72 /* Dump core if requested. */
74 && (options.dump_core == 1
75 || (options.dump_core == -1 && compile_options.dump_core == 1)))
77 #if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
78 /* Warn if a core file cannot be produced because
79 of core size limit. */
81 struct rlimit core_limit;
83 if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0)
84 st_printf ("** Warning: a core dump was requested, but the core size"
85 "limit\n** is currently zero.\n\n");
89 #if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
90 kill (getpid (), SIGQUIT);
92 st_printf ("Core dump not possible, sorry.");
100 /* Error conditions. The tricky part here is printing a message when
101 * it is the I/O subsystem that is severely wounded. Our goal is to
102 * try and print something making the fewest assumptions possible,
103 * then try to clean up before actually exiting.
105 * The following exit conditions are defined:
106 * 0 Normal program exit.
107 * 1 Terminated because of operating system error.
108 * 2 Error in the runtime library
109 * 3 Internal error in runtime library
110 * 4 Error during error processing (very bad)
112 * Other error returns are reserved for the STOP statement with a numeric code.
115 /* gfc_xtoa()-- Integer to hexadecimal conversion. */
118 gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
123 assert (len >= GFC_XTOA_BUF_SIZE);
128 p = buffer + GFC_XTOA_BUF_SIZE - 1;
135 digit += 'A' - '0' - 10;
145 /* Hopefully thread-safe wrapper for a strerror_r() style function. */
148 gf_strerror (int errnum,
149 char * buf __attribute__((unused)),
150 size_t buflen __attribute__((unused)))
152 #ifdef HAVE_STRERROR_R
153 /* TODO: How to prevent the compiler warning due to strerror_r of
154 the untaken branch having the wrong return type? */
155 if (__builtin_classify_type (strerror_r (0, buf, 0)) == 5)
157 /* GNU strerror_r() */
158 return strerror_r (errnum, buf, buflen);
162 /* POSIX strerror_r () */
163 strerror_r (errnum, buf, buflen);
167 /* strerror () is not necessarily thread-safe, but should at least
168 be available everywhere. */
169 return strerror (errnum);
174 /* show_locus()-- Print a line number and filename describing where
175 * something went wrong */
178 show_locus (st_parameter_common *cmp)
180 static char *filename;
182 if (!options.locus || cmp == NULL || cmp->filename == NULL)
187 filename = filename_from_unit (cmp->unit);
188 if (filename != NULL)
190 st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
191 (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
196 st_printf ("At line %d of file %s (unit = %d)\n",
197 (int) cmp->line, cmp->filename, (int) cmp->unit);
202 st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
206 /* recursion_check()-- It's possible for additional errors to occur
207 * during fatal error processing. We detect this condition here and
208 * exit with code 4 immediately. */
210 #define MAGIC 0x20DE8101
213 recursion_check (void)
215 static int magic = 0;
217 /* Don't even try to print something at this point */
225 #define STRERR_MAXSZ 256
227 /* os_error()-- Operating system error. We get a message from the
228 * operating system, show it and leave. Some operating system errors
229 * are caught and processed by the library. If not, we come here. */
232 os_error (const char *message)
234 char errmsg[STRERR_MAXSZ];
236 st_printf ("Operating system error: %s\n%s\n",
237 gf_strerror (errno, errmsg, STRERR_MAXSZ), message);
243 /* void runtime_error()-- These are errors associated with an
244 * invalid fortran program. */
247 runtime_error (const char *message, ...)
252 st_printf ("Fortran runtime error: ");
253 va_start (ap, message);
254 st_vprintf (message, ap);
259 iexport(runtime_error);
261 /* void runtime_error_at()-- These are errors associated with a
262 * run time error generated by the front end compiler. */
265 runtime_error_at (const char *where, const char *message, ...)
270 st_printf ("%s\n", where);
271 st_printf ("Fortran runtime error: ");
272 va_start (ap, message);
273 st_vprintf (message, ap);
278 iexport(runtime_error_at);
282 runtime_warning_at (const char *where, const char *message, ...)
286 st_printf ("%s\n", where);
287 st_printf ("Fortran runtime warning: ");
288 va_start (ap, message);
289 st_vprintf (message, ap);
293 iexport(runtime_warning_at);
296 /* void internal_error()-- These are this-can't-happen errors
297 * that indicate something deeply wrong. */
300 internal_error (st_parameter_common *cmp, const char *message)
304 st_printf ("Internal Error: %s\n", message);
306 /* This function call is here to get the main.o object file included
307 when linking statically. This works because error.o is supposed to
308 be always linked in (and the function call is in internal_error
309 because hopefully it doesn't happen too often). */
310 stupid_function_name_for_static_linking();
316 /* translate_error()-- Given an integer error code, return a string
317 * describing the error. */
320 translate_error (int code)
335 p = "Successful return";
339 p = "Operating system error";
342 case LIBERROR_BAD_OPTION:
343 p = "Bad statement option";
346 case LIBERROR_MISSING_OPTION:
347 p = "Missing statement option";
350 case LIBERROR_OPTION_CONFLICT:
351 p = "Conflicting statement options";
354 case LIBERROR_ALREADY_OPEN:
355 p = "File already opened in another unit";
358 case LIBERROR_BAD_UNIT:
359 p = "Unattached unit";
362 case LIBERROR_FORMAT:
366 case LIBERROR_BAD_ACTION:
367 p = "Incorrect ACTION specified";
370 case LIBERROR_ENDFILE:
371 p = "Read past ENDFILE record";
374 case LIBERROR_BAD_US:
375 p = "Corrupt unformatted sequential file";
378 case LIBERROR_READ_VALUE:
379 p = "Bad value during read";
382 case LIBERROR_READ_OVERFLOW:
383 p = "Numeric overflow on read";
386 case LIBERROR_INTERNAL:
387 p = "Internal error in run-time library";
390 case LIBERROR_INTERNAL_UNIT:
391 p = "Internal unit I/O error";
394 case LIBERROR_DIRECT_EOR:
395 p = "Write exceeds length of DIRECT access record";
398 case LIBERROR_SHORT_RECORD:
399 p = "I/O past end of record on unformatted file";
402 case LIBERROR_CORRUPT_FILE:
403 p = "Unformatted file structure has been corrupted";
407 p = "Unknown error code";
415 /* generate_error()-- Come here when an error happens. This
416 * subroutine is called if it is possible to continue on after the error.
417 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
418 * ERR labels are present, we return, otherwise we terminate the program
419 * after printing a message. The error code is always required but the
420 * message parameter can be NULL, in which case a string describing
421 * the most recent operating system error is used. */
424 generate_error (st_parameter_common *cmp, int family, const char *message)
426 char errmsg[STRERR_MAXSZ];
428 /* If there was a previous error, don't mask it with another
429 error message, EOF or EOR condition. */
431 if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
434 /* Set the error status. */
435 if ((cmp->flags & IOPARM_HAS_IOSTAT))
436 *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
440 (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
441 translate_error (family);
443 if (cmp->flags & IOPARM_HAS_IOMSG)
444 cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
446 /* Report status back to the compiler. */
447 cmp->flags &= ~IOPARM_LIBRETURN_MASK;
451 cmp->flags |= IOPARM_LIBRETURN_EOR;
452 if ((cmp->flags & IOPARM_EOR))
457 cmp->flags |= IOPARM_LIBRETURN_END;
458 if ((cmp->flags & IOPARM_END))
463 cmp->flags |= IOPARM_LIBRETURN_ERROR;
464 if ((cmp->flags & IOPARM_ERR))
469 /* Return if the user supplied an iostat variable. */
470 if ((cmp->flags & IOPARM_HAS_IOSTAT))
473 /* Terminate the program */
477 st_printf ("Fortran runtime error: %s\n", message);
480 iexport(generate_error);
483 /* generate_warning()-- Similar to generate_error but just give a warning. */
486 generate_warning (st_parameter_common *cmp, const char *message)
492 st_printf ("Fortran runtime warning: %s\n", message);
496 /* Whether, for a feature included in a given standard set (GFC_STD_*),
497 we should issue an error or a warning, or be quiet. */
500 notification_std (int std)
504 if (!compile_options.pedantic)
505 return NOTIFICATION_SILENT;
507 warning = compile_options.warn_std & std;
508 if ((compile_options.allow_std & std) != 0 && !warning)
509 return NOTIFICATION_SILENT;
511 return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
515 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
516 feature. An error/warning will be issued if the currently selected
517 standard does not contain the requested bits. */
520 notify_std (st_parameter_common *cmp, int std, const char * message)
524 if (!compile_options.pedantic)
527 warning = compile_options.warn_std & std;
528 if ((compile_options.allow_std & std) != 0 && !warning)
535 st_printf ("Fortran runtime error: %s\n", message);
541 st_printf ("Fortran runtime warning: %s\n", message);