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"
39 #ifdef HAVE_SYS_TIME_H
43 /* <sys/time.h> has to be included before <sys/resource.h> to work
44 around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */
45 #ifdef HAVE_SYS_RESOURCE_H
46 #include <sys/resource.h>
56 /* Termination of a program: F2008 2.3.5 talks about "normal
57 termination" and "error termination". Normal termination occurs as
58 a result of e.g. executing the end program statement, and executing
59 the STOP statement. It includes the effect of the C exit()
62 Error termination is initiated when the ERROR STOP statement is
63 executed, when ALLOCATE/DEALLOCATE fails without STAT= being
64 specified, when some of the co-array synchronization statements
65 fail without STAT= being specified, and some I/O errors if
66 ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE
67 failure without CMDSTAT=.
69 2.3.5 also explains how co-images synchronize during termination.
71 In libgfortran we have two ways of ending a program. exit(code) is
72 a normal exit; calling exit() also causes open units to be
73 closed. No backtrace or core dump is needed here. When something
74 goes wrong, we have sys_abort() which tries to print the backtrace
75 if -fbacktrace is enabled, and then dumps core; whether a core file
76 is generated is system dependent. When aborting, we don't flush and
77 close open units, as program memory might be corrupted and we'd
78 rather risk losing dirty data in the buffers rather than corrupting
83 /* Error conditions. The tricky part here is printing a message when
84 * it is the I/O subsystem that is severely wounded. Our goal is to
85 * try and print something making the fewest assumptions possible,
86 * then try to clean up before actually exiting.
88 * The following exit conditions are defined:
89 * 0 Normal program exit.
90 * 1 Terminated because of operating system error.
91 * 2 Error in the runtime library
92 * 3 Internal error in runtime library
94 * Other error returns are reserved for the STOP statement with a numeric code.
98 /* Write a null-terminated C string to standard error. This function
99 is async-signal-safe. */
102 estr_write (const char *str
)
104 return write (STDERR_FILENO
, str
, strlen (str
));
108 /* st_vprintf()-- vsnprintf-like function for error output. We use a
109 stack allocated buffer for formatting; since this function might be
110 called from within a signal handler, printing directly to stderr
111 with vfprintf is not safe since the stderr locking might lead to a
114 #define ST_VPRINTF_SIZE 512
117 st_vprintf (const char *format
, va_list ap
)
120 char buffer
[ST_VPRINTF_SIZE
];
122 #ifdef HAVE_VSNPRINTF
123 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
125 written
= vsprintf(buffer
, format
, ap
);
127 if (written
>= ST_VPRINTF_SIZE
- 1)
129 /* The error message was longer than our buffer. Ouch. Because
130 we may have messed up things badly, report the error and
132 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
133 write (STDERR_FILENO
, buffer
, ST_VPRINTF_SIZE
- 1);
134 write (STDERR_FILENO
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
141 written
= write (STDERR_FILENO
, buffer
, written
);
147 st_printf (const char * format
, ...)
151 va_start (ap
, format
);
152 written
= st_vprintf (format
, ap
);
158 /* sys_abort()-- Terminate the program showing backtrace and dumping
164 /* If backtracing is enabled, print backtrace and disable signal
166 if (options
.backtrace
== 1
167 || (options
.backtrace
== -1 && compile_options
.backtrace
== 1))
170 signal (SIGABRT
, SIG_DFL
);
177 /* gfc_xtoa()-- Integer to hexadecimal conversion. */
180 gfc_xtoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
185 assert (len
>= GFC_XTOA_BUF_SIZE
);
190 p
= buffer
+ GFC_XTOA_BUF_SIZE
- 1;
197 digit
+= 'A' - '0' - 10;
207 /* Hopefully thread-safe wrapper for a strerror_r() style function. */
210 gf_strerror (int errnum
,
211 char * buf
__attribute__((unused
)),
212 size_t buflen
__attribute__((unused
)))
214 #ifdef HAVE_STRERROR_R
215 /* POSIX returns an "int", GNU a "char*". */
217 __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf
, 0))
219 /* GNU strerror_r() */
220 strerror_r (errnum
, buf
, buflen
),
221 /* POSIX strerror_r () */
222 (strerror_r (errnum
, buf
, buflen
), buf
));
223 #elif defined(HAVE_STRERROR_R_2ARGS)
224 strerror_r (errnum
, buf
);
227 /* strerror () is not necessarily thread-safe, but should at least
228 be available everywhere. */
229 return strerror (errnum
);
234 /* show_locus()-- Print a line number and filename describing where
235 * something went wrong */
238 show_locus (st_parameter_common
*cmp
)
242 if (!options
.locus
|| cmp
== NULL
|| cmp
->filename
== NULL
)
247 filename
= filename_from_unit (cmp
->unit
);
249 if (filename
!= NULL
)
251 st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
252 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
, filename
);
257 st_printf ("At line %d of file %s (unit = %d)\n",
258 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
);
263 st_printf ("At line %d of file %s\n", (int) cmp
->line
, cmp
->filename
);
267 /* recursion_check()-- It's possible for additional errors to occur
268 * during fatal error processing. We detect this condition here and
269 * exit with code 4 immediately. */
271 #define MAGIC 0x20DE8101
274 recursion_check (void)
276 static int magic
= 0;
278 /* Don't even try to print something at this point */
286 #define STRERR_MAXSZ 256
288 /* os_error()-- Operating system error. We get a message from the
289 * operating system, show it and leave. Some operating system errors
290 * are caught and processed by the library. If not, we come here. */
293 os_error (const char *message
)
295 char errmsg
[STRERR_MAXSZ
];
297 estr_write ("Operating system error: ");
298 estr_write (gf_strerror (errno
, errmsg
, STRERR_MAXSZ
));
300 estr_write (message
);
307 /* void runtime_error()-- These are errors associated with an
308 * invalid fortran program. */
311 runtime_error (const char *message
, ...)
316 estr_write ("Fortran runtime error: ");
317 va_start (ap
, message
);
318 st_vprintf (message
, ap
);
323 iexport(runtime_error
);
325 /* void runtime_error_at()-- These are errors associated with a
326 * run time error generated by the front end compiler. */
329 runtime_error_at (const char *where
, const char *message
, ...)
335 estr_write ("\nFortran runtime error: ");
336 va_start (ap
, message
);
337 st_vprintf (message
, ap
);
342 iexport(runtime_error_at
);
346 runtime_warning_at (const char *where
, const char *message
, ...)
351 estr_write ("\nFortran runtime warning: ");
352 va_start (ap
, message
);
353 st_vprintf (message
, ap
);
357 iexport(runtime_warning_at
);
360 /* void internal_error()-- These are this-can't-happen errors
361 * that indicate something deeply wrong. */
364 internal_error (st_parameter_common
*cmp
, const char *message
)
368 estr_write ("Internal Error: ");
369 estr_write (message
);
372 /* This function call is here to get the main.o object file included
373 when linking statically. This works because error.o is supposed to
374 be always linked in (and the function call is in internal_error
375 because hopefully it doesn't happen too often). */
376 stupid_function_name_for_static_linking();
382 /* translate_error()-- Given an integer error code, return a string
383 * describing the error. */
386 translate_error (int code
)
401 p
= "Successful return";
405 p
= "Operating system error";
408 case LIBERROR_BAD_OPTION
:
409 p
= "Bad statement option";
412 case LIBERROR_MISSING_OPTION
:
413 p
= "Missing statement option";
416 case LIBERROR_OPTION_CONFLICT
:
417 p
= "Conflicting statement options";
420 case LIBERROR_ALREADY_OPEN
:
421 p
= "File already opened in another unit";
424 case LIBERROR_BAD_UNIT
:
425 p
= "Unattached unit";
428 case LIBERROR_FORMAT
:
432 case LIBERROR_BAD_ACTION
:
433 p
= "Incorrect ACTION specified";
436 case LIBERROR_ENDFILE
:
437 p
= "Read past ENDFILE record";
440 case LIBERROR_BAD_US
:
441 p
= "Corrupt unformatted sequential file";
444 case LIBERROR_READ_VALUE
:
445 p
= "Bad value during read";
448 case LIBERROR_READ_OVERFLOW
:
449 p
= "Numeric overflow on read";
452 case LIBERROR_INTERNAL
:
453 p
= "Internal error in run-time library";
456 case LIBERROR_INTERNAL_UNIT
:
457 p
= "Internal unit I/O error";
460 case LIBERROR_DIRECT_EOR
:
461 p
= "Write exceeds length of DIRECT access record";
464 case LIBERROR_SHORT_RECORD
:
465 p
= "I/O past end of record on unformatted file";
468 case LIBERROR_CORRUPT_FILE
:
469 p
= "Unformatted file structure has been corrupted";
473 p
= "Unknown error code";
481 /* generate_error()-- Come here when an error happens. This
482 * subroutine is called if it is possible to continue on after the error.
483 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
484 * ERR labels are present, we return, otherwise we terminate the program
485 * after printing a message. The error code is always required but the
486 * message parameter can be NULL, in which case a string describing
487 * the most recent operating system error is used. */
490 generate_error (st_parameter_common
*cmp
, int family
, const char *message
)
492 char errmsg
[STRERR_MAXSZ
];
494 /* If there was a previous error, don't mask it with another
495 error message, EOF or EOR condition. */
497 if ((cmp
->flags
& IOPARM_LIBRETURN_MASK
) == IOPARM_LIBRETURN_ERROR
)
500 /* Set the error status. */
501 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
502 *cmp
->iostat
= (family
== LIBERROR_OS
) ? errno
: family
;
506 (family
== LIBERROR_OS
) ? gf_strerror (errno
, errmsg
, STRERR_MAXSZ
) :
507 translate_error (family
);
509 if (cmp
->flags
& IOPARM_HAS_IOMSG
)
510 cf_strcpy (cmp
->iomsg
, cmp
->iomsg_len
, message
);
512 /* Report status back to the compiler. */
513 cmp
->flags
&= ~IOPARM_LIBRETURN_MASK
;
517 cmp
->flags
|= IOPARM_LIBRETURN_EOR
;
518 if ((cmp
->flags
& IOPARM_EOR
))
523 cmp
->flags
|= IOPARM_LIBRETURN_END
;
524 if ((cmp
->flags
& IOPARM_END
))
529 cmp
->flags
|= IOPARM_LIBRETURN_ERROR
;
530 if ((cmp
->flags
& IOPARM_ERR
))
535 /* Return if the user supplied an iostat variable. */
536 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
539 /* Terminate the program */
543 estr_write ("Fortran runtime error: ");
544 estr_write (message
);
548 iexport(generate_error
);
551 /* generate_warning()-- Similar to generate_error but just give a warning. */
554 generate_warning (st_parameter_common
*cmp
, const char *message
)
560 estr_write ("Fortran runtime warning: ");
561 estr_write (message
);
566 /* Whether, for a feature included in a given standard set (GFC_STD_*),
567 we should issue an error or a warning, or be quiet. */
570 notification_std (int std
)
574 if (!compile_options
.pedantic
)
575 return NOTIFICATION_SILENT
;
577 warning
= compile_options
.warn_std
& std
;
578 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
579 return NOTIFICATION_SILENT
;
581 return warning
? NOTIFICATION_WARNING
: NOTIFICATION_ERROR
;
585 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
586 feature. An error/warning will be issued if the currently selected
587 standard does not contain the requested bits. */
590 notify_std (st_parameter_common
*cmp
, int std
, const char * message
)
594 if (!compile_options
.pedantic
)
597 warning
= compile_options
.warn_std
& std
;
598 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
605 estr_write ("Fortran runtime error: ");
606 estr_write (message
);
613 estr_write ("Fortran runtime warning: ");
614 estr_write (message
);