1 /* Copyright (C) 2002-2018 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 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 3, or (at your option)
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
23 <http://www.gnu.org/licenses/>. */
26 #include "libgfortran.h"
36 #ifdef HAVE_SYS_TIME_H
40 /* <sys/time.h> has to be included before <sys/resource.h> to work
41 around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */
42 #ifdef HAVE_SYS_RESOURCE_H
43 #include <sys/resource.h>
60 /* Termination of a program: F2008 2.3.5 talks about "normal
61 termination" and "error termination". Normal termination occurs as
62 a result of e.g. executing the end program statement, and executing
63 the STOP statement. It includes the effect of the C exit()
66 Error termination is initiated when the ERROR STOP statement is
67 executed, when ALLOCATE/DEALLOCATE fails without STAT= being
68 specified, when some of the co-array synchronization statements
69 fail without STAT= being specified, and some I/O errors if
70 ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE
71 failure without CMDSTAT=.
73 2.3.5 also explains how co-images synchronize during termination.
75 In libgfortran we have three ways of ending a program. exit(code)
76 is a normal exit; calling exit() also causes open units to be
77 closed. No backtrace or core dump is needed here. For error
78 termination, we have exit_error(status), which prints a backtrace
79 if backtracing is enabled, then exits. Finally, when something
80 goes terribly wrong, we have sys_abort() which tries to print the
81 backtrace if -fbacktrace is enabled, and then dumps core; whether a
82 core file is generated is system dependent. When aborting, we don't
83 flush and close open units, as program memory might be corrupted
84 and we'd rather risk losing dirty data in the buffers rather than
85 corrupting files on disk.
89 /* Error conditions. The tricky part here is printing a message when
90 * it is the I/O subsystem that is severely wounded. Our goal is to
91 * try and print something making the fewest assumptions possible,
92 * then try to clean up before actually exiting.
94 * The following exit conditions are defined:
95 * 0 Normal program exit.
96 * 1 Terminated because of operating system error.
97 * 2 Error in the runtime library
98 * 3 Internal error in runtime library
100 * Other error returns are reserved for the STOP statement with a numeric code.
104 /* Write a null-terminated C string to standard error. This function
105 is async-signal-safe. */
108 estr_write (const char *str
)
110 return write (STDERR_FILENO
, str
, strlen (str
));
114 /* st_vprintf()-- vsnprintf-like function for error output. We use a
115 stack allocated buffer for formatting; since this function might be
116 called from within a signal handler, printing directly to stderr
117 with vfprintf is not safe since the stderr locking might lead to a
120 #define ST_VPRINTF_SIZE 512
123 st_vprintf (const char *format
, va_list ap
)
126 char buffer
[ST_VPRINTF_SIZE
];
128 #ifdef HAVE_VSNPRINTF
129 written
= vsnprintf(buffer
, ST_VPRINTF_SIZE
, format
, ap
);
131 written
= vsprintf(buffer
, format
, ap
);
133 if (written
>= ST_VPRINTF_SIZE
- 1)
135 /* The error message was longer than our buffer. Ouch. Because
136 we may have messed up things badly, report the error and
138 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
139 write (STDERR_FILENO
, buffer
, ST_VPRINTF_SIZE
- 1);
140 write (STDERR_FILENO
, ERROR_MESSAGE
, strlen(ERROR_MESSAGE
));
147 written
= write (STDERR_FILENO
, buffer
, written
);
153 st_printf (const char * format
, ...)
157 va_start (ap
, format
);
158 written
= st_vprintf (format
, ap
);
164 /* sys_abort()-- Terminate the program showing backtrace and dumping
170 /* If backtracing is enabled, print backtrace and disable signal
172 if (options
.backtrace
== 1
173 || (options
.backtrace
== -1 && compile_options
.backtrace
== 1))
175 estr_write ("\nProgram aborted. Backtrace:\n");
176 show_backtrace (false);
177 signal (SIGABRT
, SIG_DFL
);
184 /* Exit in case of error termination. If backtracing is enabled, print
185 backtrace, then exit. */
188 exit_error (int status
)
190 if (options
.backtrace
== 1
191 || (options
.backtrace
== -1 && compile_options
.backtrace
== 1))
193 estr_write ("\nError termination. Backtrace:\n");
194 show_backtrace (false);
201 /* gfc_xtoa()-- Integer to hexadecimal conversion. */
204 gfc_xtoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
209 assert (len
>= GFC_XTOA_BUF_SIZE
);
214 p
= buffer
+ GFC_XTOA_BUF_SIZE
- 1;
221 digit
+= 'A' - '0' - 10;
231 /* Hopefully thread-safe wrapper for a strerror() style function. */
234 gf_strerror (int errnum
,
235 char * buf
__attribute__((unused
)),
236 size_t buflen
__attribute__((unused
)))
238 #ifdef HAVE_STRERROR_L
239 locale_t myloc
= newlocale (LC_CTYPE_MASK
| LC_MESSAGES_MASK
, "",
244 p
= strerror_l (errnum
, myloc
);
248 /* newlocale might fail e.g. due to running out of memory, fall
249 back to the simpler strerror. */
250 p
= strerror (errnum
);
252 #elif defined(HAVE_STRERROR_R)
253 #ifdef HAVE_USELOCALE
254 /* Some targets (Darwin at least) have the POSIX 2008 extended
255 locale functions, but not strerror_l. So reset the per-thread
257 uselocale (LC_GLOBAL_LOCALE
);
259 /* POSIX returns an "int", GNU a "char*". */
261 __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf
, 0))
263 /* GNU strerror_r() */
264 strerror_r (errnum
, buf
, buflen
),
265 /* POSIX strerror_r () */
266 (strerror_r (errnum
, buf
, buflen
), buf
));
267 #elif defined(HAVE_STRERROR_R_2ARGS)
268 strerror_r (errnum
, buf
);
271 /* strerror () is not necessarily thread-safe, but should at least
272 be available everywhere. */
273 return strerror (errnum
);
278 /* show_locus()-- Print a line number and filename describing where
279 * something went wrong */
282 show_locus (st_parameter_common
*cmp
)
286 if (!options
.locus
|| cmp
== NULL
|| cmp
->filename
== NULL
)
291 filename
= filename_from_unit (cmp
->unit
);
293 if (filename
!= NULL
)
295 st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
296 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
, filename
);
301 st_printf ("At line %d of file %s (unit = %d)\n",
302 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
);
307 st_printf ("At line %d of file %s\n", (int) cmp
->line
, cmp
->filename
);
311 /* recursion_check()-- It's possible for additional errors to occur
312 * during fatal error processing. We detect this condition here and
313 * exit with code 4 immediately. */
315 #define MAGIC 0x20DE8101
318 recursion_check (void)
320 static int magic
= 0;
322 /* Don't even try to print something at this point */
330 #define STRERR_MAXSZ 256
332 /* os_error()-- Operating system error. We get a message from the
333 * operating system, show it and leave. Some operating system errors
334 * are caught and processed by the library. If not, we come here. */
337 os_error (const char *message
)
339 char errmsg
[STRERR_MAXSZ
];
341 estr_write ("Operating system error: ");
342 estr_write (gf_strerror (errno
, errmsg
, STRERR_MAXSZ
));
344 estr_write (message
);
351 /* void runtime_error()-- These are errors associated with an
352 * invalid fortran program. */
355 runtime_error (const char *message
, ...)
360 estr_write ("Fortran runtime error: ");
361 va_start (ap
, message
);
362 st_vprintf (message
, ap
);
367 iexport(runtime_error
);
369 /* void runtime_error_at()-- These are errors associated with a
370 * run time error generated by the front end compiler. */
373 runtime_error_at (const char *where
, const char *message
, ...)
379 estr_write ("\nFortran runtime error: ");
380 va_start (ap
, message
);
381 st_vprintf (message
, ap
);
386 iexport(runtime_error_at
);
390 runtime_warning_at (const char *where
, const char *message
, ...)
395 estr_write ("\nFortran runtime warning: ");
396 va_start (ap
, message
);
397 st_vprintf (message
, ap
);
401 iexport(runtime_warning_at
);
404 /* void internal_error()-- These are this-can't-happen errors
405 * that indicate something deeply wrong. */
408 internal_error (st_parameter_common
*cmp
, const char *message
)
412 estr_write ("Internal Error: ");
413 estr_write (message
);
416 /* This function call is here to get the main.o object file included
417 when linking statically. This works because error.o is supposed to
418 be always linked in (and the function call is in internal_error
419 because hopefully it doesn't happen too often). */
420 stupid_function_name_for_static_linking();
426 /* translate_error()-- Given an integer error code, return a string
427 * describing the error. */
430 translate_error (int code
)
445 p
= "Successful return";
449 p
= "Operating system error";
452 case LIBERROR_BAD_OPTION
:
453 p
= "Bad statement option";
456 case LIBERROR_MISSING_OPTION
:
457 p
= "Missing statement option";
460 case LIBERROR_OPTION_CONFLICT
:
461 p
= "Conflicting statement options";
464 case LIBERROR_ALREADY_OPEN
:
465 p
= "File already opened in another unit";
468 case LIBERROR_BAD_UNIT
:
469 p
= "Unattached unit";
472 case LIBERROR_FORMAT
:
476 case LIBERROR_BAD_ACTION
:
477 p
= "Incorrect ACTION specified";
480 case LIBERROR_ENDFILE
:
481 p
= "Read past ENDFILE record";
484 case LIBERROR_BAD_US
:
485 p
= "Corrupt unformatted sequential file";
488 case LIBERROR_READ_VALUE
:
489 p
= "Bad value during read";
492 case LIBERROR_READ_OVERFLOW
:
493 p
= "Numeric overflow on read";
496 case LIBERROR_INTERNAL
:
497 p
= "Internal error in run-time library";
500 case LIBERROR_INTERNAL_UNIT
:
501 p
= "Internal unit I/O error";
504 case LIBERROR_DIRECT_EOR
:
505 p
= "Write exceeds length of DIRECT access record";
508 case LIBERROR_SHORT_RECORD
:
509 p
= "I/O past end of record on unformatted file";
512 case LIBERROR_CORRUPT_FILE
:
513 p
= "Unformatted file structure has been corrupted";
516 case LIBERROR_INQUIRE_INTERNAL_UNIT
:
517 p
= "Inquire statement identifies an internal file";
521 p
= "Unknown error code";
529 /* generate_error()-- Come here when an error happens. This
530 * subroutine is called if it is possible to continue on after the error.
531 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
532 * ERR labels are present, we return, otherwise we terminate the program
533 * after printing a message. The error code is always required but the
534 * message parameter can be NULL, in which case a string describing
535 * the most recent operating system error is used. */
538 generate_error (st_parameter_common
*cmp
, int family
, const char *message
)
540 char errmsg
[STRERR_MAXSZ
];
542 /* If there was a previous error, don't mask it with another
543 error message, EOF or EOR condition. */
545 if ((cmp
->flags
& IOPARM_LIBRETURN_MASK
) == IOPARM_LIBRETURN_ERROR
)
548 /* Set the error status. */
549 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
550 *cmp
->iostat
= (family
== LIBERROR_OS
) ? errno
: family
;
554 (family
== LIBERROR_OS
) ? gf_strerror (errno
, errmsg
, STRERR_MAXSZ
) :
555 translate_error (family
);
557 if (cmp
->flags
& IOPARM_HAS_IOMSG
)
558 cf_strcpy (cmp
->iomsg
, cmp
->iomsg_len
, message
);
560 /* Report status back to the compiler. */
561 cmp
->flags
&= ~IOPARM_LIBRETURN_MASK
;
565 cmp
->flags
|= IOPARM_LIBRETURN_EOR
;
566 if ((cmp
->flags
& IOPARM_EOR
))
571 cmp
->flags
|= IOPARM_LIBRETURN_END
;
572 if ((cmp
->flags
& IOPARM_END
))
577 cmp
->flags
|= IOPARM_LIBRETURN_ERROR
;
578 if ((cmp
->flags
& IOPARM_ERR
))
583 /* Return if the user supplied an iostat variable. */
584 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
587 /* Terminate the program */
591 estr_write ("Fortran runtime error: ");
592 estr_write (message
);
596 iexport(generate_error
);
599 /* generate_warning()-- Similar to generate_error but just give a warning. */
602 generate_warning (st_parameter_common
*cmp
, const char *message
)
608 estr_write ("Fortran runtime warning: ");
609 estr_write (message
);
614 /* Whether, for a feature included in a given standard set (GFC_STD_*),
615 we should issue an error or a warning, or be quiet. */
618 notification_std (int std
)
622 if (!compile_options
.pedantic
)
623 return NOTIFICATION_SILENT
;
625 warning
= compile_options
.warn_std
& std
;
626 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
627 return NOTIFICATION_SILENT
;
629 return warning
? NOTIFICATION_WARNING
: NOTIFICATION_ERROR
;
633 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
634 feature. An error/warning will be issued if the currently selected
635 standard does not contain the requested bits. */
638 notify_std (st_parameter_common
*cmp
, int std
, const char * message
)
642 if (!compile_options
.pedantic
)
645 warning
= compile_options
.warn_std
& std
;
646 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
653 estr_write ("Fortran runtime error: ");
654 estr_write (message
);
661 estr_write ("Fortran runtime warning: ");
662 estr_write (message
);