]>
Commit | Line | Data |
---|---|---|
83ffe9cd | 1 | /* Copyright (C) 2002-2023 Free Software Foundation, Inc. |
6de9cd9a DN |
2 | Contributed by Andy Vaught |
3 | ||
bb408e87 | 4 | This file is part of the GNU Fortran runtime library (libgfortran). |
6de9cd9a | 5 | |
57dea9f6 | 6 | Libgfortran is free software; you can redistribute it and/or modify |
6de9cd9a | 7 | it under the terms of the GNU General Public License as published by |
748086b7 | 8 | the Free Software Foundation; either version 3, or (at your option) |
6de9cd9a DN |
9 | any later version. |
10 | ||
57dea9f6 | 11 | Libgfortran is distributed in the hope that it will be useful, |
6de9cd9a DN |
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. | |
15 | ||
748086b7 JJ |
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. | |
19 | ||
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/>. */ | |
6de9cd9a DN |
24 | |
25 | ||
36ae8a61 | 26 | #include "libgfortran.h" |
2b4c9065 NK |
27 | #include "io.h" |
28 | #include "async.h" | |
29 | ||
1449b8cb | 30 | #include <assert.h> |
6de9cd9a | 31 | #include <string.h> |
4a8bce89 | 32 | #include <errno.h> |
eedeea04 | 33 | #include <signal.h> |
eedeea04 FXC |
34 | |
35 | #ifdef HAVE_UNISTD_H | |
36 | #include <unistd.h> | |
37 | #endif | |
38 | ||
eedeea04 FXC |
39 | #ifdef HAVE_SYS_TIME_H |
40 | #include <sys/time.h> | |
41 | #endif | |
42 | ||
f64acab6 FXC |
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> | |
47 | #endif | |
48 | ||
6de9cd9a | 49 | |
9cbecd06 JB |
50 | #include <locale.h> |
51 | ||
52 | #ifdef HAVE_XLOCALE_H | |
53 | #include <xlocale.h> | |
54 | #endif | |
55 | ||
56 | ||
eedeea04 FXC |
57 | #ifdef __MINGW32__ |
58 | #define HAVE_GETPID 1 | |
59 | #include <process.h> | |
60 | #endif | |
61 | ||
62 | ||
de8bd142 JB |
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() | |
67 | function. | |
68 | ||
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=. | |
75 | ||
76 | 2.3.5 also explains how co-images synchronize during termination. | |
77 | ||
71cda9ca JB |
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. | |
de8bd142 JB |
89 | |
90 | */ | |
eedeea04 | 91 | |
6de9cd9a DN |
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. | |
96 | * | |
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 | |
6de9cd9a DN |
102 | * |
103 | * Other error returns are reserved for the STOP statement with a numeric code. | |
104 | */ | |
105 | ||
1028b2bd JB |
106 | |
107 | /* Write a null-terminated C string to standard error. This function | |
108 | is async-signal-safe. */ | |
109 | ||
110 | ssize_t | |
111 | estr_write (const char *str) | |
112 | { | |
113 | return write (STDERR_FILENO, str, strlen (str)); | |
114 | } | |
115 | ||
116 | ||
edaaef60 JB |
117 | /* Write a vector of strings to standard error. This function is |
118 | async-signal-safe. */ | |
1028b2bd | 119 | |
edaaef60 JB |
120 | ssize_t |
121 | estr_writev (const struct iovec *iov, int iovcnt) | |
122 | { | |
123 | #ifdef HAVE_WRITEV | |
124 | return writev (STDERR_FILENO, iov, iovcnt); | |
125 | #else | |
126 | ssize_t w = 0; | |
127 | for (int i = 0; i < iovcnt; i++) | |
128 | { | |
129 | ssize_t r = write (STDERR_FILENO, iov[i].iov_base, iov[i].iov_len); | |
130 | if (r == -1) | |
131 | return r; | |
132 | w += r; | |
133 | } | |
134 | return w; | |
135 | #endif | |
136 | } | |
1028b2bd | 137 | |
edaaef60 JB |
138 | |
139 | #ifndef HAVE_VSNPRINTF | |
140 | static int | |
141 | gf_vsnprintf (char *str, size_t size, const char *format, va_list ap) | |
1028b2bd JB |
142 | { |
143 | int written; | |
1028b2bd | 144 | |
1028b2bd JB |
145 | written = vsprintf(buffer, format, ap); |
146 | ||
edaaef60 | 147 | if (written >= size - 1) |
1028b2bd JB |
148 | { |
149 | /* The error message was longer than our buffer. Ouch. Because | |
150 | we may have messed up things badly, report the error and | |
151 | quit. */ | |
edaaef60 JB |
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)); | |
de8bd142 | 155 | sys_abort (); |
1028b2bd JB |
156 | #undef ERROR_MESSAGE |
157 | ||
158 | } | |
1028b2bd JB |
159 | return written; |
160 | } | |
161 | ||
edaaef60 JB |
162 | #define vsnprintf gf_vsnprintf |
163 | #endif | |
164 | ||
165 | ||
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. */ | |
169 | ||
170 | #define ST_ERRBUF_SIZE 512 | |
1028b2bd JB |
171 | |
172 | int | |
173 | st_printf (const char * format, ...) | |
174 | { | |
edaaef60 | 175 | char buffer[ST_ERRBUF_SIZE]; |
1028b2bd JB |
176 | int written; |
177 | va_list ap; | |
178 | va_start (ap, format); | |
edaaef60 | 179 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, format, ap); |
1028b2bd | 180 | va_end (ap); |
edaaef60 | 181 | written = write (STDERR_FILENO, buffer, written); |
1028b2bd JB |
182 | return written; |
183 | } | |
184 | ||
185 | ||
de8bd142 JB |
186 | /* sys_abort()-- Terminate the program showing backtrace and dumping |
187 | core. */ | |
188 | ||
189 | void | |
f6da75ed | 190 | sys_abort (void) |
de8bd142 JB |
191 | { |
192 | /* If backtracing is enabled, print backtrace and disable signal | |
193 | handler for ABRT. */ | |
194 | if (options.backtrace == 1 | |
195 | || (options.backtrace == -1 && compile_options.backtrace == 1)) | |
196 | { | |
f0f67c96 | 197 | estr_write ("\nProgram aborted. Backtrace:\n"); |
1b0b9fcb | 198 | show_backtrace (false); |
de8bd142 | 199 | signal (SIGABRT, SIG_DFL); |
de8bd142 JB |
200 | } |
201 | ||
202 | abort(); | |
203 | } | |
204 | ||
205 | ||
71cda9ca JB |
206 | /* Exit in case of error termination. If backtracing is enabled, print |
207 | backtrace, then exit. */ | |
208 | ||
209 | void | |
210 | exit_error (int status) | |
211 | { | |
212 | if (options.backtrace == 1 | |
213 | || (options.backtrace == -1 && compile_options.backtrace == 1)) | |
214 | { | |
215 | estr_write ("\nError termination. Backtrace:\n"); | |
216 | show_backtrace (false); | |
217 | } | |
218 | exit (status); | |
219 | } | |
220 | ||
221 | ||
9cbecd06 | 222 | /* Hopefully thread-safe wrapper for a strerror() style function. */ |
723553bd JB |
223 | |
224 | char * | |
225 | gf_strerror (int errnum, | |
226 | char * buf __attribute__((unused)), | |
227 | size_t buflen __attribute__((unused))) | |
228 | { | |
9cbecd06 JB |
229 | #ifdef HAVE_STRERROR_L |
230 | locale_t myloc = newlocale (LC_CTYPE_MASK | LC_MESSAGES_MASK, "", | |
231 | (locale_t) 0); | |
1b0b9fcb JB |
232 | char *p; |
233 | if (myloc) | |
234 | { | |
235 | p = strerror_l (errnum, myloc); | |
236 | freelocale (myloc); | |
237 | } | |
238 | else | |
239 | /* newlocale might fail e.g. due to running out of memory, fall | |
240 | back to the simpler strerror. */ | |
241 | p = strerror (errnum); | |
9cbecd06 JB |
242 | return p; |
243 | #elif defined(HAVE_STRERROR_R) | |
beb9afca | 244 | #ifdef HAVE_POSIX_2008_LOCALE |
9cbecd06 JB |
245 | /* Some targets (Darwin at least) have the POSIX 2008 extended |
246 | locale functions, but not strerror_l. So reset the per-thread | |
247 | locale here. */ | |
248 | uselocale (LC_GLOBAL_LOCALE); | |
249 | #endif | |
4179e59a | 250 | /* POSIX returns an "int", GNU a "char*". */ |
6ef98271 FXC |
251 | return |
252 | __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0)) | |
253 | == 5, | |
254 | /* GNU strerror_r() */ | |
255 | strerror_r (errnum, buf, buflen), | |
256 | /* POSIX strerror_r () */ | |
257 | (strerror_r (errnum, buf, buflen), buf)); | |
4179e59a TB |
258 | #elif defined(HAVE_STRERROR_R_2ARGS) |
259 | strerror_r (errnum, buf); | |
260 | return buf; | |
723553bd JB |
261 | #else |
262 | /* strerror () is not necessarily thread-safe, but should at least | |
263 | be available everywhere. */ | |
264 | return strerror (errnum); | |
265 | #endif | |
266 | } | |
267 | ||
268 | ||
6de9cd9a DN |
269 | /* show_locus()-- Print a line number and filename describing where |
270 | * something went wrong */ | |
271 | ||
272 | void | |
5e805e44 | 273 | show_locus (st_parameter_common *cmp) |
6de9cd9a | 274 | { |
1028b2bd | 275 | char *filename; |
87557722 | 276 | |
5e805e44 | 277 | if (!options.locus || cmp == NULL || cmp->filename == NULL) |
6de9cd9a | 278 | return; |
87557722 JD |
279 | |
280 | if (cmp->unit > 0) | |
281 | { | |
282 | filename = filename_from_unit (cmp->unit); | |
1028b2bd | 283 | |
87557722 JD |
284 | if (filename != NULL) |
285 | { | |
286 | st_printf ("At line %d of file %s (unit = %d, file = '%s')\n", | |
4e2eb53c | 287 | (int) cmp->line, cmp->filename, (int) cmp->unit, filename); |
bb408e87 | 288 | free (filename); |
87557722 | 289 | } |
c26cc9a6 JD |
290 | else |
291 | { | |
292 | st_printf ("At line %d of file %s (unit = %d)\n", | |
4e2eb53c | 293 | (int) cmp->line, cmp->filename, (int) cmp->unit); |
c26cc9a6 | 294 | } |
87557722 JD |
295 | return; |
296 | } | |
6de9cd9a | 297 | |
6c0e51c4 | 298 | st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename); |
6de9cd9a DN |
299 | } |
300 | ||
301 | ||
302 | /* recursion_check()-- It's possible for additional errors to occur | |
303 | * during fatal error processing. We detect this condition here and | |
f4c0f888 | 304 | * abort immediately. */ |
6de9cd9a | 305 | |
f4c0f888 | 306 | static __gthread_key_t recursion_key; |
6de9cd9a DN |
307 | |
308 | static void | |
309 | recursion_check (void) | |
310 | { | |
f4c0f888 JB |
311 | if (__gthread_active_p ()) |
312 | { | |
313 | bool* p = __gthread_getspecific (recursion_key); | |
314 | if (!p) | |
315 | { | |
316 | p = xcalloc (1, sizeof (bool)); | |
317 | __gthread_setspecific (recursion_key, p); | |
318 | } | |
319 | if (*p) | |
320 | sys_abort (); | |
321 | *p = true; | |
322 | } | |
323 | else | |
324 | { | |
325 | static bool recur; | |
326 | if (recur) | |
327 | sys_abort (); | |
328 | recur = true; | |
329 | } | |
330 | } | |
6de9cd9a | 331 | |
f4c0f888 JB |
332 | #ifdef __GTHREADS |
333 | static void __attribute__((constructor)) | |
334 | constructor_recursion_check (void) | |
335 | { | |
336 | if (__gthread_active_p ()) | |
337 | __gthread_key_create (&recursion_key, &free); | |
338 | } | |
6de9cd9a | 339 | |
f4c0f888 JB |
340 | static void __attribute__((destructor)) |
341 | destructor_recursion_check (void) | |
342 | { | |
343 | if (__gthread_active_p ()) | |
344 | __gthread_key_delete (recursion_key); | |
6de9cd9a | 345 | } |
f4c0f888 JB |
346 | #endif |
347 | ||
6de9cd9a DN |
348 | |
349 | ||
723553bd JB |
350 | #define STRERR_MAXSZ 256 |
351 | ||
6de9cd9a DN |
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. */ | |
355 | ||
356 | void | |
357 | os_error (const char *message) | |
358 | { | |
723553bd | 359 | char errmsg[STRERR_MAXSZ]; |
edaaef60 | 360 | struct iovec iov[5]; |
6de9cd9a | 361 | recursion_check (); |
edaaef60 JB |
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"; | |
367 | iov[2].iov_len = 1; | |
368 | iov[3].iov_base = (char*) message; | |
369 | iov[3].iov_len = strlen (message); | |
370 | iov[4].iov_base = (char*) "\n"; | |
371 | iov[4].iov_len = 1; | |
372 | estr_writev (iov, 5); | |
71cda9ca | 373 | exit_error (1); |
6de9cd9a | 374 | } |
d74a8b05 JB |
375 | iexport(os_error); /* TODO, DEPRECATED, ABI: Should not be exported |
376 | anymore when bumping so version. */ | |
377 | ||
378 | ||
379 | /* Improved version of os_error with a printf style format string and | |
380 | a locus. */ | |
381 | ||
382 | void | |
383 | os_error_at (const char *where, const char *message, ...) | |
384 | { | |
385 | char errmsg[STRERR_MAXSZ]; | |
386 | char buffer[STRERR_MAXSZ]; | |
387 | struct iovec iov[6]; | |
388 | va_list ap; | |
389 | recursion_check (); | |
390 | int written; | |
391 | ||
392 | iov[0].iov_base = (char*) where; | |
393 | iov[0].iov_len = strlen (where); | |
394 | ||
395 | iov[1].iov_base = (char*) ": "; | |
396 | iov[1].iov_len = strlen (iov[1].iov_base); | |
397 | ||
398 | va_start (ap, message); | |
399 | written = vsnprintf (buffer, STRERR_MAXSZ, message, ap); | |
400 | va_end (ap); | |
401 | iov[2].iov_base = buffer; | |
402 | if (written >= 0) | |
403 | iov[2].iov_len = written; | |
404 | else | |
405 | iov[2].iov_len = 0; | |
406 | ||
407 | iov[3].iov_base = (char*) ": "; | |
408 | iov[3].iov_len = strlen (iov[3].iov_base); | |
409 | ||
410 | iov[4].iov_base = gf_strerror (errno, errmsg, STRERR_MAXSZ); | |
411 | iov[4].iov_len = strlen (iov[4].iov_base); | |
412 | ||
413 | iov[5].iov_base = (char*) "\n"; | |
414 | iov[5].iov_len = 1; | |
415 | ||
416 | estr_writev (iov, 6); | |
417 | exit_error (1); | |
418 | } | |
419 | iexport(os_error_at); | |
6de9cd9a DN |
420 | |
421 | ||
422 | /* void runtime_error()-- These are errors associated with an | |
423 | * invalid fortran program. */ | |
424 | ||
425 | void | |
d8163f5c | 426 | runtime_error (const char *message, ...) |
6de9cd9a | 427 | { |
edaaef60 JB |
428 | char buffer[ST_ERRBUF_SIZE]; |
429 | struct iovec iov[3]; | |
d8163f5c | 430 | va_list ap; |
edaaef60 | 431 | int written; |
d8163f5c | 432 | |
6de9cd9a | 433 | recursion_check (); |
edaaef60 JB |
434 | iov[0].iov_base = (char*) "Fortran runtime error: "; |
435 | iov[0].iov_len = strlen (iov[0].iov_base); | |
d8163f5c | 436 | va_start (ap, message); |
edaaef60 | 437 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap); |
d8163f5c | 438 | va_end (ap); |
edaaef60 JB |
439 | if (written >= 0) |
440 | { | |
441 | iov[1].iov_base = buffer; | |
442 | iov[1].iov_len = written; | |
443 | iov[2].iov_base = (char*) "\n"; | |
444 | iov[2].iov_len = 1; | |
445 | estr_writev (iov, 3); | |
446 | } | |
71cda9ca | 447 | exit_error (2); |
6de9cd9a | 448 | } |
7d7b8bfe | 449 | iexport(runtime_error); |
6de9cd9a | 450 | |
cb13c288 JD |
451 | /* void runtime_error_at()-- These are errors associated with a |
452 | * run time error generated by the front end compiler. */ | |
453 | ||
454 | void | |
c8fe94c7 | 455 | runtime_error_at (const char *where, const char *message, ...) |
cb13c288 | 456 | { |
edaaef60 | 457 | char buffer[ST_ERRBUF_SIZE]; |
c8fe94c7 | 458 | va_list ap; |
edaaef60 JB |
459 | struct iovec iov[4]; |
460 | int written; | |
c8fe94c7 | 461 | |
cb13c288 | 462 | recursion_check (); |
edaaef60 JB |
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); | |
c8fe94c7 | 467 | va_start (ap, message); |
edaaef60 | 468 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap); |
c8fe94c7 | 469 | va_end (ap); |
edaaef60 JB |
470 | if (written >= 0) |
471 | { | |
472 | iov[2].iov_base = buffer; | |
473 | iov[2].iov_len = written; | |
474 | iov[3].iov_base = (char*) "\n"; | |
475 | iov[3].iov_len = 1; | |
476 | estr_writev (iov, 4); | |
477 | } | |
71cda9ca | 478 | exit_error (2); |
cb13c288 JD |
479 | } |
480 | iexport(runtime_error_at); | |
481 | ||
6de9cd9a | 482 | |
0d52899f TB |
483 | void |
484 | runtime_warning_at (const char *where, const char *message, ...) | |
485 | { | |
edaaef60 | 486 | char buffer[ST_ERRBUF_SIZE]; |
0d52899f | 487 | va_list ap; |
edaaef60 JB |
488 | struct iovec iov[4]; |
489 | int written; | |
0d52899f | 490 | |
edaaef60 JB |
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); | |
0d52899f | 495 | va_start (ap, message); |
edaaef60 | 496 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap); |
0d52899f | 497 | va_end (ap); |
edaaef60 JB |
498 | if (written >= 0) |
499 | { | |
500 | iov[2].iov_base = buffer; | |
501 | iov[2].iov_len = written; | |
502 | iov[3].iov_base = (char*) "\n"; | |
503 | iov[3].iov_len = 1; | |
504 | estr_writev (iov, 4); | |
505 | } | |
0d52899f TB |
506 | } |
507 | iexport(runtime_warning_at); | |
508 | ||
509 | ||
6de9cd9a DN |
510 | /* void internal_error()-- These are this-can't-happen errors |
511 | * that indicate something deeply wrong. */ | |
512 | ||
513 | void | |
5e805e44 | 514 | internal_error (st_parameter_common *cmp, const char *message) |
6de9cd9a | 515 | { |
edaaef60 JB |
516 | struct iovec iov[3]; |
517 | ||
6de9cd9a | 518 | recursion_check (); |
5e805e44 | 519 | show_locus (cmp); |
edaaef60 JB |
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"; | |
525 | iov[2].iov_len = 1; | |
526 | estr_writev (iov, 3); | |
f2ae4b2b FXC |
527 | |
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(); | |
533 | ||
71cda9ca | 534 | exit_error (3); |
6de9cd9a DN |
535 | } |
536 | ||
537 | ||
538 | /* translate_error()-- Given an integer error code, return a string | |
539 | * describing the error. */ | |
540 | ||
541 | const char * | |
542 | translate_error (int code) | |
543 | { | |
544 | const char *p; | |
545 | ||
546 | switch (code) | |
547 | { | |
d74b97cc | 548 | case LIBERROR_EOR: |
6de9cd9a DN |
549 | p = "End of record"; |
550 | break; | |
551 | ||
d74b97cc | 552 | case LIBERROR_END: |
6de9cd9a DN |
553 | p = "End of file"; |
554 | break; | |
555 | ||
d74b97cc | 556 | case LIBERROR_OK: |
6de9cd9a DN |
557 | p = "Successful return"; |
558 | break; | |
559 | ||
d74b97cc | 560 | case LIBERROR_OS: |
6de9cd9a DN |
561 | p = "Operating system error"; |
562 | break; | |
563 | ||
d74b97cc | 564 | case LIBERROR_BAD_OPTION: |
6de9cd9a DN |
565 | p = "Bad statement option"; |
566 | break; | |
567 | ||
d74b97cc | 568 | case LIBERROR_MISSING_OPTION: |
6de9cd9a DN |
569 | p = "Missing statement option"; |
570 | break; | |
571 | ||
d74b97cc | 572 | case LIBERROR_OPTION_CONFLICT: |
6de9cd9a DN |
573 | p = "Conflicting statement options"; |
574 | break; | |
575 | ||
d74b97cc | 576 | case LIBERROR_ALREADY_OPEN: |
6de9cd9a DN |
577 | p = "File already opened in another unit"; |
578 | break; | |
579 | ||
d74b97cc | 580 | case LIBERROR_BAD_UNIT: |
6de9cd9a DN |
581 | p = "Unattached unit"; |
582 | break; | |
583 | ||
d74b97cc | 584 | case LIBERROR_FORMAT: |
6de9cd9a DN |
585 | p = "FORMAT error"; |
586 | break; | |
587 | ||
d74b97cc | 588 | case LIBERROR_BAD_ACTION: |
6de9cd9a DN |
589 | p = "Incorrect ACTION specified"; |
590 | break; | |
591 | ||
d74b97cc | 592 | case LIBERROR_ENDFILE: |
6de9cd9a DN |
593 | p = "Read past ENDFILE record"; |
594 | break; | |
595 | ||
d74b97cc | 596 | case LIBERROR_BAD_US: |
6de9cd9a DN |
597 | p = "Corrupt unformatted sequential file"; |
598 | break; | |
599 | ||
d74b97cc | 600 | case LIBERROR_READ_VALUE: |
6de9cd9a DN |
601 | p = "Bad value during read"; |
602 | break; | |
603 | ||
d74b97cc | 604 | case LIBERROR_READ_OVERFLOW: |
6de9cd9a DN |
605 | p = "Numeric overflow on read"; |
606 | break; | |
607 | ||
d74b97cc | 608 | case LIBERROR_INTERNAL: |
844234fb JD |
609 | p = "Internal error in run-time library"; |
610 | break; | |
611 | ||
d74b97cc | 612 | case LIBERROR_INTERNAL_UNIT: |
844234fb JD |
613 | p = "Internal unit I/O error"; |
614 | break; | |
615 | ||
d74b97cc | 616 | case LIBERROR_DIRECT_EOR: |
54f9e278 JD |
617 | p = "Write exceeds length of DIRECT access record"; |
618 | break; | |
619 | ||
d74b97cc | 620 | case LIBERROR_SHORT_RECORD: |
07b3bbf2 | 621 | p = "I/O past end of record on unformatted file"; |
8a7f7fb6 TK |
622 | break; |
623 | ||
d74b97cc | 624 | case LIBERROR_CORRUPT_FILE: |
b4c811bd TK |
625 | p = "Unformatted file structure has been corrupted"; |
626 | break; | |
627 | ||
351b4432 JD |
628 | case LIBERROR_INQUIRE_INTERNAL_UNIT: |
629 | p = "Inquire statement identifies an internal file"; | |
630 | break; | |
631 | ||
8df7ee67 TK |
632 | case LIBERROR_BAD_WAIT_ID: |
633 | p = "Bad ID in WAIT statement"; | |
634 | break; | |
635 | ||
6de9cd9a DN |
636 | default: |
637 | p = "Unknown error code"; | |
638 | break; | |
639 | } | |
640 | ||
641 | return p; | |
642 | } | |
643 | ||
644 | ||
2b4c9065 NK |
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. */ | |
6de9cd9a | 647 | |
2b4c9065 NK |
648 | bool |
649 | generate_error_common (st_parameter_common *cmp, int family, const char *message) | |
6de9cd9a | 650 | { |
723553bd | 651 | char errmsg[STRERR_MAXSZ]; |
ceac3d59 | 652 | |
2b4c9065 NK |
653 | #if ASYNC_IO |
654 | gfc_unit *u; | |
655 | ||
656 | NOTE ("Entering generate_error_common"); | |
657 | ||
658 | u = thread_unit; | |
659 | if (u && u->au) | |
660 | { | |
661 | if (u->au->error.has_error) | |
662 | return true; | |
663 | ||
664 | if (__gthread_equal (u->au->thread, __gthread_self ())) | |
665 | { | |
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; | |
670 | return true; | |
671 | } | |
672 | } | |
673 | #endif | |
674 | ||
ceac3d59 TK |
675 | /* If there was a previous error, don't mask it with another |
676 | error message, EOF or EOR condition. */ | |
677 | ||
678 | if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR) | |
2b4c9065 | 679 | return true; |
ceac3d59 | 680 | |
244fada7 | 681 | /* Set the error status. */ |
5e805e44 | 682 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
d74b97cc | 683 | *cmp->iostat = (family == LIBERROR_OS) ? errno : family; |
6de9cd9a | 684 | |
7aba8abe TK |
685 | if (message == NULL) |
686 | message = | |
723553bd JB |
687 | (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) : |
688 | translate_error (family); | |
7aba8abe | 689 | |
5e805e44 JJ |
690 | if (cmp->flags & IOPARM_HAS_IOMSG) |
691 | cf_strcpy (cmp->iomsg, cmp->iomsg_len, message); | |
7aba8abe | 692 | |
244fada7 | 693 | /* Report status back to the compiler. */ |
5e805e44 | 694 | cmp->flags &= ~IOPARM_LIBRETURN_MASK; |
6de9cd9a DN |
695 | switch (family) |
696 | { | |
d74b97cc | 697 | case LIBERROR_EOR: |
2b4c9065 | 698 | cmp->flags |= IOPARM_LIBRETURN_EOR; NOTE("EOR"); |
5e805e44 | 699 | if ((cmp->flags & IOPARM_EOR)) |
2b4c9065 | 700 | return true; |
6de9cd9a DN |
701 | break; |
702 | ||
d74b97cc | 703 | case LIBERROR_END: |
2b4c9065 | 704 | cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END"); |
5e805e44 | 705 | if ((cmp->flags & IOPARM_END)) |
2b4c9065 | 706 | return true; |
6de9cd9a DN |
707 | break; |
708 | ||
709 | default: | |
2b4c9065 | 710 | cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR"); |
5e805e44 | 711 | if ((cmp->flags & IOPARM_ERR)) |
2b4c9065 | 712 | return true; |
6de9cd9a DN |
713 | break; |
714 | } | |
715 | ||
244fada7 | 716 | /* Return if the user supplied an iostat variable. */ |
5e805e44 | 717 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
2b4c9065 | 718 | return true; |
6de9cd9a | 719 | |
2b4c9065 NK |
720 | /* Return code, caller is responsible for terminating |
721 | the program if necessary. */ | |
6de9cd9a | 722 | |
5e805e44 JJ |
723 | recursion_check (); |
724 | show_locus (cmp); | |
edaaef60 JB |
725 | struct iovec iov[3]; |
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"; | |
731 | iov[2].iov_len = 1; | |
732 | estr_writev (iov, 3); | |
2b4c9065 NK |
733 | return false; |
734 | } | |
735 | ||
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. */ | |
745 | ||
746 | void | |
747 | generate_error (st_parameter_common *cmp, int family, const char *message) | |
748 | { | |
749 | if (generate_error_common (cmp, family, message)) | |
750 | return; | |
751 | ||
752 | exit_error(2); | |
6de9cd9a | 753 | } |
cb13c288 | 754 | iexport(generate_error); |
8b67b708 | 755 | |
fc5f5bb7 JD |
756 | |
757 | /* generate_warning()-- Similar to generate_error but just give a warning. */ | |
758 | ||
759 | void | |
760 | generate_warning (st_parameter_common *cmp, const char *message) | |
761 | { | |
762 | if (message == NULL) | |
763 | message = " "; | |
764 | ||
765 | show_locus (cmp); | |
edaaef60 JB |
766 | struct iovec iov[3]; |
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"; | |
772 | iov[2].iov_len = 1; | |
773 | estr_writev (iov, 3); | |
fc5f5bb7 JD |
774 | } |
775 | ||
776 | ||
8f0d39a8 FXC |
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. */ | |
779 | ||
780 | notification | |
781 | notification_std (int std) | |
782 | { | |
783 | int warning; | |
784 | ||
785 | if (!compile_options.pedantic) | |
b2ef02df | 786 | return NOTIFICATION_SILENT; |
8f0d39a8 FXC |
787 | |
788 | warning = compile_options.warn_std & std; | |
789 | if ((compile_options.allow_std & std) != 0 && !warning) | |
b2ef02df | 790 | return NOTIFICATION_SILENT; |
8f0d39a8 | 791 | |
b2ef02df | 792 | return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR; |
8f0d39a8 FXC |
793 | } |
794 | ||
795 | ||
8b67b708 FXC |
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. */ | |
799 | ||
f5e3ed2d | 800 | bool |
2e444427 | 801 | notify_std (st_parameter_common *cmp, int std, const char * message) |
8b67b708 FXC |
802 | { |
803 | int warning; | |
edaaef60 | 804 | struct iovec iov[3]; |
8b67b708 | 805 | |
5f8f5313 | 806 | if (!compile_options.pedantic) |
f5e3ed2d | 807 | return true; |
5f8f5313 | 808 | |
8b67b708 FXC |
809 | warning = compile_options.warn_std & std; |
810 | if ((compile_options.allow_std & std) != 0 && !warning) | |
f5e3ed2d | 811 | return true; |
8b67b708 | 812 | |
8b67b708 FXC |
813 | if (!warning) |
814 | { | |
2e444427 JD |
815 | recursion_check (); |
816 | show_locus (cmp); | |
edaaef60 JB |
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"; | |
822 | iov[2].iov_len = 1; | |
823 | estr_writev (iov, 3); | |
71cda9ca | 824 | exit_error (2); |
8b67b708 FXC |
825 | } |
826 | else | |
2e444427 JD |
827 | { |
828 | show_locus (cmp); | |
edaaef60 JB |
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"; | |
834 | iov[2].iov_len = 1; | |
835 | estr_writev (iov, 3); | |
2e444427 | 836 | } |
f5e3ed2d | 837 | return false; |
8b67b708 | 838 | } |