1 /* Copyright (C) 2002-2024 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);
222 /* Hopefully thread-safe wrapper for a strerror() style function. */
225 gf_strerror (int errnum
,
226 char * buf
__attribute__((unused
)),
227 size_t buflen
__attribute__((unused
)))
229 #ifdef HAVE_STRERROR_L
230 locale_t myloc
= newlocale (LC_CTYPE_MASK
| LC_MESSAGES_MASK
, "",
235 p
= strerror_l (errnum
, myloc
);
239 /* newlocale might fail e.g. due to running out of memory, fall
240 back to the simpler strerror. */
241 p
= strerror (errnum
);
243 #elif defined(HAVE_STRERROR_R)
244 #ifdef HAVE_POSIX_2008_LOCALE
245 /* Some targets (Darwin at least) have the POSIX 2008 extended
246 locale functions, but not strerror_l. So reset the per-thread
248 uselocale (LC_GLOBAL_LOCALE
);
250 /* POSIX returns an "int", GNU a "char*". */
252 __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf
, 0))
254 /* GNU strerror_r() */
255 strerror_r (errnum
, buf
, buflen
),
256 /* POSIX strerror_r () */
257 (strerror_r (errnum
, buf
, buflen
), buf
));
258 #elif defined(HAVE_STRERROR_R_2ARGS)
259 strerror_r (errnum
, buf
);
262 /* strerror () is not necessarily thread-safe, but should at least
263 be available everywhere. */
264 return strerror (errnum
);
269 /* show_locus()-- Print a line number and filename describing where
270 * something went wrong */
273 show_locus (st_parameter_common
*cmp
)
277 if (!options
.locus
|| cmp
== NULL
|| cmp
->filename
== NULL
)
282 filename
= filename_from_unit (cmp
->unit
);
284 if (filename
!= NULL
)
286 st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
287 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
, filename
);
292 st_printf ("At line %d of file %s (unit = %d)\n",
293 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
);
298 st_printf ("At line %d of file %s\n", (int) cmp
->line
, cmp
->filename
);
302 /* recursion_check()-- It's possible for additional errors to occur
303 * during fatal error processing. We detect this condition here and
304 * abort immediately. */
306 static __gthread_key_t recursion_key
;
309 recursion_check (void)
311 if (__gthread_active_p ())
313 bool* p
= __gthread_getspecific (recursion_key
);
316 p
= xcalloc (1, sizeof (bool));
317 __gthread_setspecific (recursion_key
, p
);
333 static void __attribute__((constructor
))
334 constructor_recursion_check (void)
336 if (__gthread_active_p ())
337 __gthread_key_create (&recursion_key
, &free
);
340 static void __attribute__((destructor
))
341 destructor_recursion_check (void)
343 if (__gthread_active_p ())
344 __gthread_key_delete (recursion_key
);
350 #define STRERR_MAXSZ 256
352 /* os_error()-- Operating system error. We get a message from the
353 * operating system, show it and leave. Some operating system errors
354 * are caught and processed by the library. If not, we come here. */
357 os_error (const char *message
)
359 char errmsg
[STRERR_MAXSZ
];
362 iov
[0].iov_base
= (char*) "Operating system error: ";
363 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
364 iov
[1].iov_base
= gf_strerror (errno
, errmsg
, STRERR_MAXSZ
);
365 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
366 iov
[2].iov_base
= (char*) "\n";
368 iov
[3].iov_base
= (char*) message
;
369 iov
[3].iov_len
= strlen (message
);
370 iov
[4].iov_base
= (char*) "\n";
372 estr_writev (iov
, 5);
375 iexport(os_error
); /* TODO, DEPRECATED, ABI: Should not be exported
376 anymore when bumping so version. */
379 /* Improved version of os_error with a printf style format string and
383 os_error_at (const char *where
, const char *message
, ...)
385 char errmsg
[STRERR_MAXSZ
];
386 char buffer
[STRERR_MAXSZ
];
392 iov
[0].iov_base
= (char*) where
;
393 iov
[0].iov_len
= strlen (where
);
395 iov
[1].iov_base
= (char*) ": ";
396 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
398 va_start (ap
, message
);
399 written
= vsnprintf (buffer
, STRERR_MAXSZ
, message
, ap
);
401 iov
[2].iov_base
= buffer
;
403 iov
[2].iov_len
= written
;
407 iov
[3].iov_base
= (char*) ": ";
408 iov
[3].iov_len
= strlen (iov
[3].iov_base
);
410 iov
[4].iov_base
= gf_strerror (errno
, errmsg
, STRERR_MAXSZ
);
411 iov
[4].iov_len
= strlen (iov
[4].iov_base
);
413 iov
[5].iov_base
= (char*) "\n";
416 estr_writev (iov
, 6);
419 iexport(os_error_at
);
422 /* void runtime_error()-- These are errors associated with an
423 * invalid fortran program. */
426 runtime_error (const char *message
, ...)
428 char buffer
[ST_ERRBUF_SIZE
];
434 iov
[0].iov_base
= (char*) "Fortran runtime error: ";
435 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
436 va_start (ap
, message
);
437 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, message
, ap
);
441 iov
[1].iov_base
= buffer
;
442 iov
[1].iov_len
= written
;
443 iov
[2].iov_base
= (char*) "\n";
445 estr_writev (iov
, 3);
449 iexport(runtime_error
);
451 /* void runtime_error_at()-- These are errors associated with a
452 * run time error generated by the front end compiler. */
455 runtime_error_at (const char *where
, const char *message
, ...)
457 char buffer
[ST_ERRBUF_SIZE
];
463 iov
[0].iov_base
= (char*) where
;
464 iov
[0].iov_len
= strlen (where
);
465 iov
[1].iov_base
= (char*) "\nFortran runtime error: ";
466 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
467 va_start (ap
, message
);
468 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, message
, ap
);
472 iov
[2].iov_base
= buffer
;
473 iov
[2].iov_len
= written
;
474 iov
[3].iov_base
= (char*) "\n";
476 estr_writev (iov
, 4);
480 iexport(runtime_error_at
);
484 runtime_warning_at (const char *where
, const char *message
, ...)
486 char buffer
[ST_ERRBUF_SIZE
];
491 iov
[0].iov_base
= (char*) where
;
492 iov
[0].iov_len
= strlen (where
);
493 iov
[1].iov_base
= (char*) "\nFortran runtime warning: ";
494 iov
[1].iov_len
= strlen (iov
[1].iov_base
);
495 va_start (ap
, message
);
496 written
= vsnprintf (buffer
, ST_ERRBUF_SIZE
, message
, ap
);
500 iov
[2].iov_base
= buffer
;
501 iov
[2].iov_len
= written
;
502 iov
[3].iov_base
= (char*) "\n";
504 estr_writev (iov
, 4);
507 iexport(runtime_warning_at
);
510 /* void internal_error()-- These are this-can't-happen errors
511 * that indicate something deeply wrong. */
514 internal_error (st_parameter_common
*cmp
, const char *message
)
520 iov
[0].iov_base
= (char*) "Internal Error: ";
521 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
522 iov
[1].iov_base
= (char*) message
;
523 iov
[1].iov_len
= strlen (message
);
524 iov
[2].iov_base
= (char*) "\n";
526 estr_writev (iov
, 3);
528 /* This function call is here to get the main.o object file included
529 when linking statically. This works because error.o is supposed to
530 be always linked in (and the function call is in internal_error
531 because hopefully it doesn't happen too often). */
532 stupid_function_name_for_static_linking();
538 /* translate_error()-- Given an integer error code, return a string
539 * describing the error. */
542 translate_error (int code
)
557 p
= "Successful return";
561 p
= "Operating system error";
564 case LIBERROR_BAD_OPTION
:
565 p
= "Bad statement option";
568 case LIBERROR_MISSING_OPTION
:
569 p
= "Missing statement option";
572 case LIBERROR_OPTION_CONFLICT
:
573 p
= "Conflicting statement options";
576 case LIBERROR_ALREADY_OPEN
:
577 p
= "File already opened in another unit";
580 case LIBERROR_BAD_UNIT
:
581 p
= "Unattached unit";
584 case LIBERROR_FORMAT
:
588 case LIBERROR_BAD_ACTION
:
589 p
= "Incorrect ACTION specified";
592 case LIBERROR_ENDFILE
:
593 p
= "Read past ENDFILE record";
596 case LIBERROR_BAD_US
:
597 p
= "Corrupt unformatted sequential file";
600 case LIBERROR_READ_VALUE
:
601 p
= "Bad value during read";
604 case LIBERROR_READ_OVERFLOW
:
605 p
= "Numeric overflow on read";
608 case LIBERROR_INTERNAL
:
609 p
= "Internal error in run-time library";
612 case LIBERROR_INTERNAL_UNIT
:
613 p
= "Internal unit I/O error";
616 case LIBERROR_DIRECT_EOR
:
617 p
= "Write exceeds length of DIRECT access record";
620 case LIBERROR_SHORT_RECORD
:
621 p
= "I/O past end of record on unformatted file";
624 case LIBERROR_CORRUPT_FILE
:
625 p
= "Unformatted file structure has been corrupted";
628 case LIBERROR_INQUIRE_INTERNAL_UNIT
:
629 p
= "Inquire statement identifies an internal file";
632 case LIBERROR_BAD_WAIT_ID
:
633 p
= "Bad ID in WAIT statement";
637 p
= "Unknown error code";
645 /* Worker function for generate_error and generate_error_async. Return true
646 if a straight return is to be done, zero if the program should abort. */
649 generate_error_common (st_parameter_common
*cmp
, int family
, const char *message
)
651 char errmsg
[STRERR_MAXSZ
];
656 NOTE ("Entering generate_error_common");
661 if (u
->au
->error
.has_error
)
664 if (__gthread_equal (u
->au
->thread
, __gthread_self ()))
666 u
->au
->error
.has_error
= 1;
667 u
->au
->error
.cmp
= cmp
;
668 u
->au
->error
.family
= family
;
669 u
->au
->error
.message
= message
;
675 /* If there was a previous error, don't mask it with another
676 error message, EOF or EOR condition. */
678 if ((cmp
->flags
& IOPARM_LIBRETURN_MASK
) == IOPARM_LIBRETURN_ERROR
)
681 /* Set the error status. */
682 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
683 *cmp
->iostat
= (family
== LIBERROR_OS
) ? errno
: family
;
687 (family
== LIBERROR_OS
) ? gf_strerror (errno
, errmsg
, STRERR_MAXSZ
) :
688 translate_error (family
);
690 if (cmp
->flags
& IOPARM_HAS_IOMSG
)
691 cf_strcpy (cmp
->iomsg
, cmp
->iomsg_len
, message
);
693 /* Report status back to the compiler. */
694 cmp
->flags
&= ~IOPARM_LIBRETURN_MASK
;
698 cmp
->flags
|= IOPARM_LIBRETURN_EOR
; NOTE("EOR");
699 if ((cmp
->flags
& IOPARM_EOR
))
704 cmp
->flags
|= IOPARM_LIBRETURN_END
; NOTE("END");
705 if ((cmp
->flags
& IOPARM_END
))
710 cmp
->flags
|= IOPARM_LIBRETURN_ERROR
; NOTE("ERROR");
711 if ((cmp
->flags
& IOPARM_ERR
))
716 /* Return if the user supplied an iostat variable. */
717 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
720 /* Return code, caller is responsible for terminating
721 the program if necessary. */
726 iov
[0].iov_base
= (char*) "Fortran runtime error: ";
727 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
728 iov
[1].iov_base
= (char*) message
;
729 iov
[1].iov_len
= strlen (message
);
730 iov
[2].iov_base
= (char*) "\n";
732 estr_writev (iov
, 3);
736 /* generate_error()-- Come here when an error happens. This
737 * subroutine is called if it is possible to continue on after the error.
738 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
739 * ERR labels are present, we return, otherwise we terminate the program
740 * after printing a message. The error code is always required but the
741 * message parameter can be NULL, in which case a string describing
742 * the most recent operating system error is used.
743 * If the error is for an asynchronous unit and if the program is currently
744 * executing the asynchronous thread, just mark the error and return. */
747 generate_error (st_parameter_common
*cmp
, int family
, const char *message
)
749 if (generate_error_common (cmp
, family
, message
))
754 iexport(generate_error
);
757 /* generate_warning()-- Similar to generate_error but just give a warning. */
760 generate_warning (st_parameter_common
*cmp
, const char *message
)
767 iov
[0].iov_base
= (char*) "Fortran runtime warning: ";
768 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
769 iov
[1].iov_base
= (char*) message
;
770 iov
[1].iov_len
= strlen (message
);
771 iov
[2].iov_base
= (char*) "\n";
773 estr_writev (iov
, 3);
777 /* Whether, for a feature included in a given standard set (GFC_STD_*),
778 we should issue an error or a warning, or be quiet. */
781 notification_std (int std
)
785 if (!compile_options
.pedantic
)
786 return NOTIFICATION_SILENT
;
788 warning
= compile_options
.warn_std
& std
;
789 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
790 return NOTIFICATION_SILENT
;
792 return warning
? NOTIFICATION_WARNING
: NOTIFICATION_ERROR
;
796 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
797 feature. An error/warning will be issued if the currently selected
798 standard does not contain the requested bits. */
801 notify_std (st_parameter_common
*cmp
, int std
, const char * message
)
806 if (!compile_options
.pedantic
)
809 warning
= compile_options
.warn_std
& std
;
810 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
817 iov
[0].iov_base
= (char*) "Fortran runtime error: ";
818 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
819 iov
[1].iov_base
= (char*) message
;
820 iov
[1].iov_len
= strlen (message
);
821 iov
[2].iov_base
= (char*) "\n";
823 estr_writev (iov
, 3);
829 iov
[0].iov_base
= (char*) "Fortran runtime warning: ";
830 iov
[0].iov_len
= strlen (iov
[0].iov_base
);
831 iov
[1].iov_base
= (char*) message
;
832 iov
[1].iov_len
= strlen (message
);
833 iov
[2].iov_base
= (char*) "\n";
835 estr_writev (iov
, 3);