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"
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>
63 /* Termination of a program: F2008 2.3.5 talks about "normal
64 termination" and "error termination". Normal termination occurs as
65 a result of e.g. executing the end program statement, and executing
66 the STOP statement. It includes the effect of the C exit()
69 Error termination is initiated when the ERROR STOP statement is
70 executed, when ALLOCATE/DEALLOCATE fails without STAT= being
71 specified, when some of the co-array synchronization statements
72 fail without STAT= being specified, and some I/O errors if
73 ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE
74 failure without CMDSTAT=.
76 2.3.5 also explains how co-images synchronize during termination.
78 In libgfortran we have three ways of ending a program. exit(code)
79 is a normal exit; calling exit() also causes open units to be
80 closed. No backtrace or core dump is needed here. For error
81 termination, we have exit_error(status), which prints a backtrace
82 if backtracing is enabled, then exits. Finally, when something
83 goes terribly wrong, we have sys_abort() which tries to print the
84 backtrace if -fbacktrace is enabled, and then dumps core; whether a
85 core file is generated is system dependent. When aborting, we don't
86 flush and close open units, as program memory might be corrupted
87 and we'd rather risk losing dirty data in the buffers rather than
88 corrupting files on disk.
92 /* Error conditions. The tricky part here is printing a message when
93 * it is the I/O subsystem that is severely wounded. Our goal is to
94 * try and print something making the fewest assumptions possible,
95 * then try to clean up before actually exiting.
97 * The following exit conditions are defined:
98 * 0 Normal program exit.
99 * 1 Terminated because of operating system error.
100 * 2 Error in the runtime library
101 * 3 Internal error in runtime library
103 * Other error returns are reserved for the STOP statement with a numeric code.
107 /* Write a null-terminated C string to standard error. This function
108 is async-signal-safe. */
111 estr_write (const char *str
)
113 return write (STDERR_FILENO
, str
, strlen (str
));
117 /* Write a vector of strings to standard error. This function is
118 async-signal-safe. */
121 estr_writev (const struct iovec
*iov
, int iovcnt
)
124 return writev (STDERR_FILENO
, iov
, iovcnt
);
127 for (int i
= 0; i
< iovcnt
; i
++)
129 ssize_t r
= write (STDERR_FILENO
, iov
[i
].iov_base
, iov
[i
].iov_len
);
139 #ifndef HAVE_VSNPRINTF
141 gf_vsnprintf (char *str
, size_t size
, const char *format
, va_list ap
)
145 written
= vsprintf(buffer
, format
, ap
);
147 if (written
>= size
- 1)
149 /* The error message was longer than our buffer. Ouch. Because
150 we may have messed up things badly, report the error and
152 #define ERROR_MESSAGE "Internal error: buffer overrun in gf_vsnprintf()\n"
153 write (STDERR_FILENO
, buffer
, size
- 1);
154 write (STDERR_FILENO
, ERROR_MESSAGE
, strlen (ERROR_MESSAGE
));
162 #define vsnprintf gf_vsnprintf
166 /* printf() like function for for printing to stderr. Uses a stack
167 allocated buffer and doesn't lock stderr, so it should be safe to
168 use from within a signal handler. */
170 #define ST_ERRBUF_SIZE 512
173 st_printf (const char * format
, ...)
175 char buffer
[ST_ERRBUF_SIZE
];
178 va_start (ap
, format
);
179 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, format
, ap
);
181 written
= write (STDERR_FILENO
, buffer
, written
);
186 /* sys_abort()-- Terminate the program showing backtrace and dumping
192 /* If backtracing is enabled, print backtrace and disable signal
194 if (options
.backtrace
== 1
195 || (options
.backtrace
== -1 && compile_options
.backtrace
== 1))
197 estr_write ("\nProgram aborted. Backtrace:\n");
198 show_backtrace (false);
199 signal (SIGABRT
, SIG_DFL
);
206 /* Exit in case of error termination. If backtracing is enabled, print
207 backtrace, then exit. */
210 exit_error (int status
)
212 if (options
.backtrace
== 1
213 || (options
.backtrace
== -1 && compile_options
.backtrace
== 1))
215 estr_write ("\nError termination. Backtrace:\n");
216 show_backtrace (false);
223 /* gfc_xtoa()-- Integer to hexadecimal conversion. */
226 gfc_xtoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
231 assert (len
>= GFC_XTOA_BUF_SIZE
);
236 p
= buffer
+ GFC_XTOA_BUF_SIZE
- 1;
243 digit
+= 'A' - '0' - 10;
253 /* Hopefully thread-safe wrapper for a strerror() style function. */
256 gf_strerror (int errnum
,
257 char * buf
__attribute__((unused
)),
258 size_t buflen
__attribute__((unused
)))
260 #ifdef HAVE_STRERROR_L
261 locale_t myloc
= newlocale (LC_CTYPE_MASK
| LC_MESSAGES_MASK
, "",
266 p
= strerror_l (errnum
, myloc
);
270 /* newlocale might fail e.g. due to running out of memory, fall
271 back to the simpler strerror. */
272 p
= strerror (errnum
);
274 #elif defined(HAVE_STRERROR_R)
275 #ifdef HAVE_USELOCALE
276 /* Some targets (Darwin at least) have the POSIX 2008 extended
277 locale functions, but not strerror_l. So reset the per-thread
279 uselocale (LC_GLOBAL_LOCALE
);
281 /* POSIX returns an "int", GNU a "char*". */
283 __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf
, 0))
285 /* GNU strerror_r() */
286 strerror_r (errnum
, buf
, buflen
),
287 /* POSIX strerror_r () */
288 (strerror_r (errnum
, buf
, buflen
), buf
));
289 #elif defined(HAVE_STRERROR_R_2ARGS)
290 strerror_r (errnum
, buf
);
293 /* strerror () is not necessarily thread-safe, but should at least
294 be available everywhere. */
295 return strerror (errnum
);
300 /* show_locus()-- Print a line number and filename describing where
301 * something went wrong */
304 show_locus (st_parameter_common
*cmp
)
308 if (!options
.locus
|| cmp
== NULL
|| cmp
->filename
== NULL
)
313 filename
= filename_from_unit (cmp
->unit
);
315 if (filename
!= NULL
)
317 st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
318 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
, filename
);
323 st_printf ("At line %d of file %s (unit = %d)\n",
324 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
);
329 st_printf ("At line %d of file %s\n", (int) cmp
->line
, cmp
->filename
);
333 /* recursion_check()-- It's possible for additional errors to occur
334 * during fatal error processing. We detect this condition here and
335 * abort immediately. */
337 static __gthread_key_t recursion_key
;
340 recursion_check (void)
342 if (__gthread_active_p ())
344 bool* p
= __gthread_getspecific (recursion_key
);
347 p
= xcalloc (1, sizeof (bool));
348 __gthread_setspecific (recursion_key
, p
);
364 static void __attribute__((constructor
))
365 constructor_recursion_check (void)
367 if (__gthread_active_p ())
368 __gthread_key_create (&recursion_key
, &free
);
371 static void __attribute__((destructor
))
372 destructor_recursion_check (void)
374 if (__gthread_active_p ())
375 __gthread_key_delete (recursion_key
);
381 #define STRERR_MAXSZ 256
383 /* os_error()-- Operating system error. We get a message from the
384 * operating system, show it and leave. Some operating system errors
385 * are caught and processed by the library. If not, we come here. */
388 os_error (const char *message
)
390 char errmsg
[STRERR_MAXSZ
];
393 iov
[0].iov_base
= (char*) "Operating system error: ";
394 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
395 iov
[1].iov_base
= gf_strerror (errno
, errmsg
, STRERR_MAXSZ
);
396 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
397 iov
[2].iov_base
= (char*) "\n";
399 iov
[3].iov_base
= (char*) message
;
400 iov
[3].iov_len
= strlen (message
);
401 iov
[4].iov_base
= (char*) "\n";
403 estr_writev (iov
, 5);
409 /* void runtime_error()-- These are errors associated with an
410 * invalid fortran program. */
413 runtime_error (const char *message
, ...)
415 char buffer
[ST_ERRBUF_SIZE
];
421 iov
[0].iov_base
= (char*) "Fortran runtime error: ";
422 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
423 va_start (ap
, message
);
424 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, message
, ap
);
428 iov
[1].iov_base
= buffer
;
429 iov
[1].iov_len
= written
;
430 iov
[2].iov_base
= (char*) "\n";
432 estr_writev (iov
, 3);
436 iexport(runtime_error
);
438 /* void runtime_error_at()-- These are errors associated with a
439 * run time error generated by the front end compiler. */
442 runtime_error_at (const char *where
, const char *message
, ...)
444 char buffer
[ST_ERRBUF_SIZE
];
450 iov
[0].iov_base
= (char*) where
;
451 iov
[0].iov_len
= strlen (where
);
452 iov
[1].iov_base
= (char*) "\nFortran runtime error: ";
453 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
454 va_start (ap
, message
);
455 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, message
, ap
);
459 iov
[2].iov_base
= buffer
;
460 iov
[2].iov_len
= written
;
461 iov
[3].iov_base
= (char*) "\n";
463 estr_writev (iov
, 4);
467 iexport(runtime_error_at
);
471 runtime_warning_at (const char *where
, const char *message
, ...)
473 char buffer
[ST_ERRBUF_SIZE
];
478 iov
[0].iov_base
= (char*) where
;
479 iov
[0].iov_len
= strlen (where
);
480 iov
[1].iov_base
= (char*) "\nFortran runtime warning: ";
481 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
482 va_start (ap
, message
);
483 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, message
, ap
);
487 iov
[2].iov_base
= buffer
;
488 iov
[2].iov_len
= written
;
489 iov
[3].iov_base
= (char*) "\n";
491 estr_writev (iov
, 4);
494 iexport(runtime_warning_at
);
497 /* void internal_error()-- These are this-can't-happen errors
498 * that indicate something deeply wrong. */
501 internal_error (st_parameter_common
*cmp
, const char *message
)
507 iov
[0].iov_base
= (char*) "Internal Error: ";
508 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
509 iov
[1].iov_base
= (char*) message
;
510 iov
[1].iov_len
= strlen (message
);
511 iov
[2].iov_base
= (char*) "\n";
513 estr_writev (iov
, 3);
515 /* This function call is here to get the main.o object file included
516 when linking statically. This works because error.o is supposed to
517 be always linked in (and the function call is in internal_error
518 because hopefully it doesn't happen too often). */
519 stupid_function_name_for_static_linking();
525 /* translate_error()-- Given an integer error code, return a string
526 * describing the error. */
529 translate_error (int code
)
544 p
= "Successful return";
548 p
= "Operating system error";
551 case LIBERROR_BAD_OPTION
:
552 p
= "Bad statement option";
555 case LIBERROR_MISSING_OPTION
:
556 p
= "Missing statement option";
559 case LIBERROR_OPTION_CONFLICT
:
560 p
= "Conflicting statement options";
563 case LIBERROR_ALREADY_OPEN
:
564 p
= "File already opened in another unit";
567 case LIBERROR_BAD_UNIT
:
568 p
= "Unattached unit";
571 case LIBERROR_FORMAT
:
575 case LIBERROR_BAD_ACTION
:
576 p
= "Incorrect ACTION specified";
579 case LIBERROR_ENDFILE
:
580 p
= "Read past ENDFILE record";
583 case LIBERROR_BAD_US
:
584 p
= "Corrupt unformatted sequential file";
587 case LIBERROR_READ_VALUE
:
588 p
= "Bad value during read";
591 case LIBERROR_READ_OVERFLOW
:
592 p
= "Numeric overflow on read";
595 case LIBERROR_INTERNAL
:
596 p
= "Internal error in run-time library";
599 case LIBERROR_INTERNAL_UNIT
:
600 p
= "Internal unit I/O error";
603 case LIBERROR_DIRECT_EOR
:
604 p
= "Write exceeds length of DIRECT access record";
607 case LIBERROR_SHORT_RECORD
:
608 p
= "I/O past end of record on unformatted file";
611 case LIBERROR_CORRUPT_FILE
:
612 p
= "Unformatted file structure has been corrupted";
615 case LIBERROR_INQUIRE_INTERNAL_UNIT
:
616 p
= "Inquire statement identifies an internal file";
620 p
= "Unknown error code";
628 /* Worker function for generate_error and generate_error_async. Return true
629 if a straight return is to be done, zero if the program should abort. */
632 generate_error_common (st_parameter_common
*cmp
, int family
, const char *message
)
634 char errmsg
[STRERR_MAXSZ
];
639 NOTE ("Entering generate_error_common");
644 if (u
->au
->error
.has_error
)
647 if (__gthread_equal (u
->au
->thread
, __gthread_self ()))
649 u
->au
->error
.has_error
= 1;
650 u
->au
->error
.cmp
= cmp
;
651 u
->au
->error
.family
= family
;
652 u
->au
->error
.message
= message
;
658 /* If there was a previous error, don't mask it with another
659 error message, EOF or EOR condition. */
661 if ((cmp
->flags
& IOPARM_LIBRETURN_MASK
) == IOPARM_LIBRETURN_ERROR
)
664 /* Set the error status. */
665 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
666 *cmp
->iostat
= (family
== LIBERROR_OS
) ? errno
: family
;
670 (family
== LIBERROR_OS
) ? gf_strerror (errno
, errmsg
, STRERR_MAXSZ
) :
671 translate_error (family
);
673 if (cmp
->flags
& IOPARM_HAS_IOMSG
)
674 cf_strcpy (cmp
->iomsg
, cmp
->iomsg_len
, message
);
676 /* Report status back to the compiler. */
677 cmp
->flags
&= ~IOPARM_LIBRETURN_MASK
;
681 cmp
->flags
|= IOPARM_LIBRETURN_EOR
; NOTE("EOR");
682 if ((cmp
->flags
& IOPARM_EOR
))
687 cmp
->flags
|= IOPARM_LIBRETURN_END
; NOTE("END");
688 if ((cmp
->flags
& IOPARM_END
))
693 cmp
->flags
|= IOPARM_LIBRETURN_ERROR
; NOTE("ERROR");
694 if ((cmp
->flags
& IOPARM_ERR
))
699 /* Return if the user supplied an iostat variable. */
700 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
703 /* Return code, caller is responsible for terminating
704 the program if necessary. */
709 iov
[0].iov_base
= (char*) "Fortran runtime error: ";
710 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
711 iov
[1].iov_base
= (char*) message
;
712 iov
[1].iov_len
= strlen (message
);
713 iov
[2].iov_base
= (char*) "\n";
715 estr_writev (iov
, 3);
719 /* generate_error()-- Come here when an error happens. This
720 * subroutine is called if it is possible to continue on after the error.
721 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
722 * ERR labels are present, we return, otherwise we terminate the program
723 * after printing a message. The error code is always required but the
724 * message parameter can be NULL, in which case a string describing
725 * the most recent operating system error is used.
726 * If the error is for an asynchronous unit and if the program is currently
727 * executing the asynchronous thread, just mark the error and return. */
730 generate_error (st_parameter_common
*cmp
, int family
, const char *message
)
732 if (generate_error_common (cmp
, family
, message
))
737 iexport(generate_error
);
740 /* generate_warning()-- Similar to generate_error but just give a warning. */
743 generate_warning (st_parameter_common
*cmp
, const char *message
)
750 iov
[0].iov_base
= (char*) "Fortran runtime warning: ";
751 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
752 iov
[1].iov_base
= (char*) message
;
753 iov
[1].iov_len
= strlen (message
);
754 iov
[2].iov_base
= (char*) "\n";
756 estr_writev (iov
, 3);
760 /* Whether, for a feature included in a given standard set (GFC_STD_*),
761 we should issue an error or a warning, or be quiet. */
764 notification_std (int std
)
768 if (!compile_options
.pedantic
)
769 return NOTIFICATION_SILENT
;
771 warning
= compile_options
.warn_std
& std
;
772 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
773 return NOTIFICATION_SILENT
;
775 return warning
? NOTIFICATION_WARNING
: NOTIFICATION_ERROR
;
779 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
780 feature. An error/warning will be issued if the currently selected
781 standard does not contain the requested bits. */
784 notify_std (st_parameter_common
*cmp
, int std
, const char * message
)
789 if (!compile_options
.pedantic
)
792 warning
= compile_options
.warn_std
& std
;
793 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
800 iov
[0].iov_base
= (char*) "Fortran runtime error: ";
801 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
802 iov
[1].iov_base
= (char*) message
;
803 iov
[1].iov_len
= strlen (message
);
804 iov
[2].iov_base
= (char*) "\n";
806 estr_writev (iov
, 3);
812 iov
[0].iov_base
= (char*) "Fortran runtime warning: ";
813 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
814 iov
[1].iov_base
= (char*) message
;
815 iov
[1].iov_len
= strlen (message
);
816 iov
[2].iov_base
= (char*) "\n";
818 estr_writev (iov
, 3);