1 /* Copyright (C) 2002-2021 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_POSIX_2008_LOCALE
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);
406 iexport(os_error
); /* TODO, DEPRECATED, ABI: Should not be exported
407 anymore when bumping so version. */
410 /* Improved version of os_error with a printf style format string and
414 os_error_at (const char *where
, const char *message
, ...)
416 char errmsg
[STRERR_MAXSZ
];
417 char buffer
[STRERR_MAXSZ
];
423 iov
[0].iov_base
= (char*) where
;
424 iov
[0].iov_len
= strlen (where
);
426 iov
[1].iov_base
= (char*) ": ";
427 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
429 va_start (ap
, message
);
430 written
= vsnprintf (buffer
, STRERR_MAXSZ
, message
, ap
);
432 iov
[2].iov_base
= buffer
;
434 iov
[2].iov_len
= written
;
438 iov
[3].iov_base
= (char*) ": ";
439 iov
[3].iov_len
= strlen (iov
[3].iov_base
);
441 iov
[4].iov_base
= gf_strerror (errno
, errmsg
, STRERR_MAXSZ
);
442 iov
[4].iov_len
= strlen (iov
[4].iov_base
);
444 iov
[5].iov_base
= (char*) "\n";
447 estr_writev (iov
, 6);
450 iexport(os_error_at
);
453 /* void runtime_error()-- These are errors associated with an
454 * invalid fortran program. */
457 runtime_error (const char *message
, ...)
459 char buffer
[ST_ERRBUF_SIZE
];
465 iov
[0].iov_base
= (char*) "Fortran runtime error: ";
466 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
467 va_start (ap
, message
);
468 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, message
, ap
);
472 iov
[1].iov_base
= buffer
;
473 iov
[1].iov_len
= written
;
474 iov
[2].iov_base
= (char*) "\n";
476 estr_writev (iov
, 3);
480 iexport(runtime_error
);
482 /* void runtime_error_at()-- These are errors associated with a
483 * run time error generated by the front end compiler. */
486 runtime_error_at (const char *where
, const char *message
, ...)
488 char buffer
[ST_ERRBUF_SIZE
];
494 iov
[0].iov_base
= (char*) where
;
495 iov
[0].iov_len
= strlen (where
);
496 iov
[1].iov_base
= (char*) "\nFortran runtime error: ";
497 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
498 va_start (ap
, message
);
499 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, message
, ap
);
503 iov
[2].iov_base
= buffer
;
504 iov
[2].iov_len
= written
;
505 iov
[3].iov_base
= (char*) "\n";
507 estr_writev (iov
, 4);
511 iexport(runtime_error_at
);
515 runtime_warning_at (const char *where
, const char *message
, ...)
517 char buffer
[ST_ERRBUF_SIZE
];
522 iov
[0].iov_base
= (char*) where
;
523 iov
[0].iov_len
= strlen (where
);
524 iov
[1].iov_base
= (char*) "\nFortran runtime warning: ";
525 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
526 va_start (ap
, message
);
527 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, message
, ap
);
531 iov
[2].iov_base
= buffer
;
532 iov
[2].iov_len
= written
;
533 iov
[3].iov_base
= (char*) "\n";
535 estr_writev (iov
, 4);
538 iexport(runtime_warning_at
);
541 /* void internal_error()-- These are this-can't-happen errors
542 * that indicate something deeply wrong. */
545 internal_error (st_parameter_common
*cmp
, const char *message
)
551 iov
[0].iov_base
= (char*) "Internal Error: ";
552 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
553 iov
[1].iov_base
= (char*) message
;
554 iov
[1].iov_len
= strlen (message
);
555 iov
[2].iov_base
= (char*) "\n";
557 estr_writev (iov
, 3);
559 /* This function call is here to get the main.o object file included
560 when linking statically. This works because error.o is supposed to
561 be always linked in (and the function call is in internal_error
562 because hopefully it doesn't happen too often). */
563 stupid_function_name_for_static_linking();
569 /* translate_error()-- Given an integer error code, return a string
570 * describing the error. */
573 translate_error (int code
)
588 p
= "Successful return";
592 p
= "Operating system error";
595 case LIBERROR_BAD_OPTION
:
596 p
= "Bad statement option";
599 case LIBERROR_MISSING_OPTION
:
600 p
= "Missing statement option";
603 case LIBERROR_OPTION_CONFLICT
:
604 p
= "Conflicting statement options";
607 case LIBERROR_ALREADY_OPEN
:
608 p
= "File already opened in another unit";
611 case LIBERROR_BAD_UNIT
:
612 p
= "Unattached unit";
615 case LIBERROR_FORMAT
:
619 case LIBERROR_BAD_ACTION
:
620 p
= "Incorrect ACTION specified";
623 case LIBERROR_ENDFILE
:
624 p
= "Read past ENDFILE record";
627 case LIBERROR_BAD_US
:
628 p
= "Corrupt unformatted sequential file";
631 case LIBERROR_READ_VALUE
:
632 p
= "Bad value during read";
635 case LIBERROR_READ_OVERFLOW
:
636 p
= "Numeric overflow on read";
639 case LIBERROR_INTERNAL
:
640 p
= "Internal error in run-time library";
643 case LIBERROR_INTERNAL_UNIT
:
644 p
= "Internal unit I/O error";
647 case LIBERROR_DIRECT_EOR
:
648 p
= "Write exceeds length of DIRECT access record";
651 case LIBERROR_SHORT_RECORD
:
652 p
= "I/O past end of record on unformatted file";
655 case LIBERROR_CORRUPT_FILE
:
656 p
= "Unformatted file structure has been corrupted";
659 case LIBERROR_INQUIRE_INTERNAL_UNIT
:
660 p
= "Inquire statement identifies an internal file";
663 case LIBERROR_BAD_WAIT_ID
:
664 p
= "Bad ID in WAIT statement";
668 p
= "Unknown error code";
676 /* Worker function for generate_error and generate_error_async. Return true
677 if a straight return is to be done, zero if the program should abort. */
680 generate_error_common (st_parameter_common
*cmp
, int family
, const char *message
)
682 char errmsg
[STRERR_MAXSZ
];
687 NOTE ("Entering generate_error_common");
692 if (u
->au
->error
.has_error
)
695 if (__gthread_equal (u
->au
->thread
, __gthread_self ()))
697 u
->au
->error
.has_error
= 1;
698 u
->au
->error
.cmp
= cmp
;
699 u
->au
->error
.family
= family
;
700 u
->au
->error
.message
= message
;
706 /* If there was a previous error, don't mask it with another
707 error message, EOF or EOR condition. */
709 if ((cmp
->flags
& IOPARM_LIBRETURN_MASK
) == IOPARM_LIBRETURN_ERROR
)
712 /* Set the error status. */
713 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
714 *cmp
->iostat
= (family
== LIBERROR_OS
) ? errno
: family
;
718 (family
== LIBERROR_OS
) ? gf_strerror (errno
, errmsg
, STRERR_MAXSZ
) :
719 translate_error (family
);
721 if (cmp
->flags
& IOPARM_HAS_IOMSG
)
722 cf_strcpy (cmp
->iomsg
, cmp
->iomsg_len
, message
);
724 /* Report status back to the compiler. */
725 cmp
->flags
&= ~IOPARM_LIBRETURN_MASK
;
729 cmp
->flags
|= IOPARM_LIBRETURN_EOR
; NOTE("EOR");
730 if ((cmp
->flags
& IOPARM_EOR
))
735 cmp
->flags
|= IOPARM_LIBRETURN_END
; NOTE("END");
736 if ((cmp
->flags
& IOPARM_END
))
741 cmp
->flags
|= IOPARM_LIBRETURN_ERROR
; NOTE("ERROR");
742 if ((cmp
->flags
& IOPARM_ERR
))
747 /* Return if the user supplied an iostat variable. */
748 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
751 /* Return code, caller is responsible for terminating
752 the program if necessary. */
757 iov
[0].iov_base
= (char*) "Fortran runtime error: ";
758 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
759 iov
[1].iov_base
= (char*) message
;
760 iov
[1].iov_len
= strlen (message
);
761 iov
[2].iov_base
= (char*) "\n";
763 estr_writev (iov
, 3);
767 /* generate_error()-- Come here when an error happens. This
768 * subroutine is called if it is possible to continue on after the error.
769 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
770 * ERR labels are present, we return, otherwise we terminate the program
771 * after printing a message. The error code is always required but the
772 * message parameter can be NULL, in which case a string describing
773 * the most recent operating system error is used.
774 * If the error is for an asynchronous unit and if the program is currently
775 * executing the asynchronous thread, just mark the error and return. */
778 generate_error (st_parameter_common
*cmp
, int family
, const char *message
)
780 if (generate_error_common (cmp
, family
, message
))
785 iexport(generate_error
);
788 /* generate_warning()-- Similar to generate_error but just give a warning. */
791 generate_warning (st_parameter_common
*cmp
, const char *message
)
798 iov
[0].iov_base
= (char*) "Fortran runtime warning: ";
799 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
800 iov
[1].iov_base
= (char*) message
;
801 iov
[1].iov_len
= strlen (message
);
802 iov
[2].iov_base
= (char*) "\n";
804 estr_writev (iov
, 3);
808 /* Whether, for a feature included in a given standard set (GFC_STD_*),
809 we should issue an error or a warning, or be quiet. */
812 notification_std (int std
)
816 if (!compile_options
.pedantic
)
817 return NOTIFICATION_SILENT
;
819 warning
= compile_options
.warn_std
& std
;
820 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
821 return NOTIFICATION_SILENT
;
823 return warning
? NOTIFICATION_WARNING
: NOTIFICATION_ERROR
;
827 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
828 feature. An error/warning will be issued if the currently selected
829 standard does not contain the requested bits. */
832 notify_std (st_parameter_common
*cmp
, int std
, const char * message
)
837 if (!compile_options
.pedantic
)
840 warning
= compile_options
.warn_std
& std
;
841 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
848 iov
[0].iov_base
= (char*) "Fortran runtime error: ";
849 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
850 iov
[1].iov_base
= (char*) message
;
851 iov
[1].iov_len
= strlen (message
);
852 iov
[2].iov_base
= (char*) "\n";
854 estr_writev (iov
, 3);
860 iov
[0].iov_base
= (char*) "Fortran runtime warning: ";
861 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
862 iov
[1].iov_base
= (char*) message
;
863 iov
[1].iov_len
= strlen (message
);
864 iov
[2].iov_base
= (char*) "\n";
866 estr_writev (iov
, 3);