]>
Commit | Line | Data |
---|---|---|
85ec4feb | 1 | /* Copyright (C) 2002-2018 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 | ||
222 | ||
f9bfed22 | 223 | /* gfc_xtoa()-- Integer to hexadecimal conversion. */ |
6de9cd9a | 224 | |
1449b8cb | 225 | const char * |
f9bfed22 | 226 | gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) |
6de9cd9a DN |
227 | { |
228 | int digit; | |
229 | char *p; | |
230 | ||
1449b8cb JJ |
231 | assert (len >= GFC_XTOA_BUF_SIZE); |
232 | ||
6de9cd9a | 233 | if (n == 0) |
1449b8cb | 234 | return "0"; |
6de9cd9a | 235 | |
1449b8cb JJ |
236 | p = buffer + GFC_XTOA_BUF_SIZE - 1; |
237 | *p = '\0'; | |
6de9cd9a DN |
238 | |
239 | while (n != 0) | |
240 | { | |
241 | digit = n & 0xF; | |
242 | if (digit > 9) | |
243 | digit += 'A' - '0' - 10; | |
244 | ||
1449b8cb | 245 | *--p = '0' + digit; |
6de9cd9a DN |
246 | n >>= 4; |
247 | } | |
248 | ||
1449b8cb | 249 | return p; |
6de9cd9a DN |
250 | } |
251 | ||
723553bd | 252 | |
9cbecd06 | 253 | /* Hopefully thread-safe wrapper for a strerror() style function. */ |
723553bd JB |
254 | |
255 | char * | |
256 | gf_strerror (int errnum, | |
257 | char * buf __attribute__((unused)), | |
258 | size_t buflen __attribute__((unused))) | |
259 | { | |
9cbecd06 JB |
260 | #ifdef HAVE_STRERROR_L |
261 | locale_t myloc = newlocale (LC_CTYPE_MASK | LC_MESSAGES_MASK, "", | |
262 | (locale_t) 0); | |
1b0b9fcb JB |
263 | char *p; |
264 | if (myloc) | |
265 | { | |
266 | p = strerror_l (errnum, myloc); | |
267 | freelocale (myloc); | |
268 | } | |
269 | else | |
270 | /* newlocale might fail e.g. due to running out of memory, fall | |
271 | back to the simpler strerror. */ | |
272 | p = strerror (errnum); | |
9cbecd06 JB |
273 | return p; |
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 | |
278 | locale here. */ | |
279 | uselocale (LC_GLOBAL_LOCALE); | |
280 | #endif | |
4179e59a | 281 | /* POSIX returns an "int", GNU a "char*". */ |
6ef98271 FXC |
282 | return |
283 | __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0)) | |
284 | == 5, | |
285 | /* GNU strerror_r() */ | |
286 | strerror_r (errnum, buf, buflen), | |
287 | /* POSIX strerror_r () */ | |
288 | (strerror_r (errnum, buf, buflen), buf)); | |
4179e59a TB |
289 | #elif defined(HAVE_STRERROR_R_2ARGS) |
290 | strerror_r (errnum, buf); | |
291 | return buf; | |
723553bd JB |
292 | #else |
293 | /* strerror () is not necessarily thread-safe, but should at least | |
294 | be available everywhere. */ | |
295 | return strerror (errnum); | |
296 | #endif | |
297 | } | |
298 | ||
299 | ||
6de9cd9a DN |
300 | /* show_locus()-- Print a line number and filename describing where |
301 | * something went wrong */ | |
302 | ||
303 | void | |
5e805e44 | 304 | show_locus (st_parameter_common *cmp) |
6de9cd9a | 305 | { |
1028b2bd | 306 | char *filename; |
87557722 | 307 | |
5e805e44 | 308 | if (!options.locus || cmp == NULL || cmp->filename == NULL) |
6de9cd9a | 309 | return; |
87557722 JD |
310 | |
311 | if (cmp->unit > 0) | |
312 | { | |
313 | filename = filename_from_unit (cmp->unit); | |
1028b2bd | 314 | |
87557722 JD |
315 | if (filename != NULL) |
316 | { | |
317 | st_printf ("At line %d of file %s (unit = %d, file = '%s')\n", | |
4e2eb53c | 318 | (int) cmp->line, cmp->filename, (int) cmp->unit, filename); |
bb408e87 | 319 | free (filename); |
87557722 | 320 | } |
c26cc9a6 JD |
321 | else |
322 | { | |
323 | st_printf ("At line %d of file %s (unit = %d)\n", | |
4e2eb53c | 324 | (int) cmp->line, cmp->filename, (int) cmp->unit); |
c26cc9a6 | 325 | } |
87557722 JD |
326 | return; |
327 | } | |
6de9cd9a | 328 | |
6c0e51c4 | 329 | st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename); |
6de9cd9a DN |
330 | } |
331 | ||
332 | ||
333 | /* recursion_check()-- It's possible for additional errors to occur | |
334 | * during fatal error processing. We detect this condition here and | |
f4c0f888 | 335 | * abort immediately. */ |
6de9cd9a | 336 | |
f4c0f888 | 337 | static __gthread_key_t recursion_key; |
6de9cd9a DN |
338 | |
339 | static void | |
340 | recursion_check (void) | |
341 | { | |
f4c0f888 JB |
342 | if (__gthread_active_p ()) |
343 | { | |
344 | bool* p = __gthread_getspecific (recursion_key); | |
345 | if (!p) | |
346 | { | |
347 | p = xcalloc (1, sizeof (bool)); | |
348 | __gthread_setspecific (recursion_key, p); | |
349 | } | |
350 | if (*p) | |
351 | sys_abort (); | |
352 | *p = true; | |
353 | } | |
354 | else | |
355 | { | |
356 | static bool recur; | |
357 | if (recur) | |
358 | sys_abort (); | |
359 | recur = true; | |
360 | } | |
361 | } | |
6de9cd9a | 362 | |
f4c0f888 JB |
363 | #ifdef __GTHREADS |
364 | static void __attribute__((constructor)) | |
365 | constructor_recursion_check (void) | |
366 | { | |
367 | if (__gthread_active_p ()) | |
368 | __gthread_key_create (&recursion_key, &free); | |
369 | } | |
6de9cd9a | 370 | |
f4c0f888 JB |
371 | static void __attribute__((destructor)) |
372 | destructor_recursion_check (void) | |
373 | { | |
374 | if (__gthread_active_p ()) | |
375 | __gthread_key_delete (recursion_key); | |
6de9cd9a | 376 | } |
f4c0f888 JB |
377 | #endif |
378 | ||
6de9cd9a DN |
379 | |
380 | ||
723553bd JB |
381 | #define STRERR_MAXSZ 256 |
382 | ||
6de9cd9a DN |
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. */ | |
386 | ||
387 | void | |
388 | os_error (const char *message) | |
389 | { | |
723553bd | 390 | char errmsg[STRERR_MAXSZ]; |
edaaef60 | 391 | struct iovec iov[5]; |
6de9cd9a | 392 | recursion_check (); |
edaaef60 JB |
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"; | |
398 | iov[2].iov_len = 1; | |
399 | iov[3].iov_base = (char*) message; | |
400 | iov[3].iov_len = strlen (message); | |
401 | iov[4].iov_base = (char*) "\n"; | |
402 | iov[4].iov_len = 1; | |
403 | estr_writev (iov, 5); | |
71cda9ca | 404 | exit_error (1); |
6de9cd9a | 405 | } |
1529b8d9 | 406 | iexport(os_error); |
6de9cd9a DN |
407 | |
408 | ||
409 | /* void runtime_error()-- These are errors associated with an | |
410 | * invalid fortran program. */ | |
411 | ||
412 | void | |
d8163f5c | 413 | runtime_error (const char *message, ...) |
6de9cd9a | 414 | { |
edaaef60 JB |
415 | char buffer[ST_ERRBUF_SIZE]; |
416 | struct iovec iov[3]; | |
d8163f5c | 417 | va_list ap; |
edaaef60 | 418 | int written; |
d8163f5c | 419 | |
6de9cd9a | 420 | recursion_check (); |
edaaef60 JB |
421 | iov[0].iov_base = (char*) "Fortran runtime error: "; |
422 | iov[0].iov_len = strlen (iov[0].iov_base); | |
d8163f5c | 423 | va_start (ap, message); |
edaaef60 | 424 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap); |
d8163f5c | 425 | va_end (ap); |
edaaef60 JB |
426 | if (written >= 0) |
427 | { | |
428 | iov[1].iov_base = buffer; | |
429 | iov[1].iov_len = written; | |
430 | iov[2].iov_base = (char*) "\n"; | |
431 | iov[2].iov_len = 1; | |
432 | estr_writev (iov, 3); | |
433 | } | |
71cda9ca | 434 | exit_error (2); |
6de9cd9a | 435 | } |
7d7b8bfe | 436 | iexport(runtime_error); |
6de9cd9a | 437 | |
cb13c288 JD |
438 | /* void runtime_error_at()-- These are errors associated with a |
439 | * run time error generated by the front end compiler. */ | |
440 | ||
441 | void | |
c8fe94c7 | 442 | runtime_error_at (const char *where, const char *message, ...) |
cb13c288 | 443 | { |
edaaef60 | 444 | char buffer[ST_ERRBUF_SIZE]; |
c8fe94c7 | 445 | va_list ap; |
edaaef60 JB |
446 | struct iovec iov[4]; |
447 | int written; | |
c8fe94c7 | 448 | |
cb13c288 | 449 | recursion_check (); |
edaaef60 JB |
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); | |
c8fe94c7 | 454 | va_start (ap, message); |
edaaef60 | 455 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap); |
c8fe94c7 | 456 | va_end (ap); |
edaaef60 JB |
457 | if (written >= 0) |
458 | { | |
459 | iov[2].iov_base = buffer; | |
460 | iov[2].iov_len = written; | |
461 | iov[3].iov_base = (char*) "\n"; | |
462 | iov[3].iov_len = 1; | |
463 | estr_writev (iov, 4); | |
464 | } | |
71cda9ca | 465 | exit_error (2); |
cb13c288 JD |
466 | } |
467 | iexport(runtime_error_at); | |
468 | ||
6de9cd9a | 469 | |
0d52899f TB |
470 | void |
471 | runtime_warning_at (const char *where, const char *message, ...) | |
472 | { | |
edaaef60 | 473 | char buffer[ST_ERRBUF_SIZE]; |
0d52899f | 474 | va_list ap; |
edaaef60 JB |
475 | struct iovec iov[4]; |
476 | int written; | |
0d52899f | 477 | |
edaaef60 JB |
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); | |
0d52899f | 482 | va_start (ap, message); |
edaaef60 | 483 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap); |
0d52899f | 484 | va_end (ap); |
edaaef60 JB |
485 | if (written >= 0) |
486 | { | |
487 | iov[2].iov_base = buffer; | |
488 | iov[2].iov_len = written; | |
489 | iov[3].iov_base = (char*) "\n"; | |
490 | iov[3].iov_len = 1; | |
491 | estr_writev (iov, 4); | |
492 | } | |
0d52899f TB |
493 | } |
494 | iexport(runtime_warning_at); | |
495 | ||
496 | ||
6de9cd9a DN |
497 | /* void internal_error()-- These are this-can't-happen errors |
498 | * that indicate something deeply wrong. */ | |
499 | ||
500 | void | |
5e805e44 | 501 | internal_error (st_parameter_common *cmp, const char *message) |
6de9cd9a | 502 | { |
edaaef60 JB |
503 | struct iovec iov[3]; |
504 | ||
6de9cd9a | 505 | recursion_check (); |
5e805e44 | 506 | show_locus (cmp); |
edaaef60 JB |
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"; | |
512 | iov[2].iov_len = 1; | |
513 | estr_writev (iov, 3); | |
f2ae4b2b FXC |
514 | |
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(); | |
520 | ||
71cda9ca | 521 | exit_error (3); |
6de9cd9a DN |
522 | } |
523 | ||
524 | ||
525 | /* translate_error()-- Given an integer error code, return a string | |
526 | * describing the error. */ | |
527 | ||
528 | const char * | |
529 | translate_error (int code) | |
530 | { | |
531 | const char *p; | |
532 | ||
533 | switch (code) | |
534 | { | |
d74b97cc | 535 | case LIBERROR_EOR: |
6de9cd9a DN |
536 | p = "End of record"; |
537 | break; | |
538 | ||
d74b97cc | 539 | case LIBERROR_END: |
6de9cd9a DN |
540 | p = "End of file"; |
541 | break; | |
542 | ||
d74b97cc | 543 | case LIBERROR_OK: |
6de9cd9a DN |
544 | p = "Successful return"; |
545 | break; | |
546 | ||
d74b97cc | 547 | case LIBERROR_OS: |
6de9cd9a DN |
548 | p = "Operating system error"; |
549 | break; | |
550 | ||
d74b97cc | 551 | case LIBERROR_BAD_OPTION: |
6de9cd9a DN |
552 | p = "Bad statement option"; |
553 | break; | |
554 | ||
d74b97cc | 555 | case LIBERROR_MISSING_OPTION: |
6de9cd9a DN |
556 | p = "Missing statement option"; |
557 | break; | |
558 | ||
d74b97cc | 559 | case LIBERROR_OPTION_CONFLICT: |
6de9cd9a DN |
560 | p = "Conflicting statement options"; |
561 | break; | |
562 | ||
d74b97cc | 563 | case LIBERROR_ALREADY_OPEN: |
6de9cd9a DN |
564 | p = "File already opened in another unit"; |
565 | break; | |
566 | ||
d74b97cc | 567 | case LIBERROR_BAD_UNIT: |
6de9cd9a DN |
568 | p = "Unattached unit"; |
569 | break; | |
570 | ||
d74b97cc | 571 | case LIBERROR_FORMAT: |
6de9cd9a DN |
572 | p = "FORMAT error"; |
573 | break; | |
574 | ||
d74b97cc | 575 | case LIBERROR_BAD_ACTION: |
6de9cd9a DN |
576 | p = "Incorrect ACTION specified"; |
577 | break; | |
578 | ||
d74b97cc | 579 | case LIBERROR_ENDFILE: |
6de9cd9a DN |
580 | p = "Read past ENDFILE record"; |
581 | break; | |
582 | ||
d74b97cc | 583 | case LIBERROR_BAD_US: |
6de9cd9a DN |
584 | p = "Corrupt unformatted sequential file"; |
585 | break; | |
586 | ||
d74b97cc | 587 | case LIBERROR_READ_VALUE: |
6de9cd9a DN |
588 | p = "Bad value during read"; |
589 | break; | |
590 | ||
d74b97cc | 591 | case LIBERROR_READ_OVERFLOW: |
6de9cd9a DN |
592 | p = "Numeric overflow on read"; |
593 | break; | |
594 | ||
d74b97cc | 595 | case LIBERROR_INTERNAL: |
844234fb JD |
596 | p = "Internal error in run-time library"; |
597 | break; | |
598 | ||
d74b97cc | 599 | case LIBERROR_INTERNAL_UNIT: |
844234fb JD |
600 | p = "Internal unit I/O error"; |
601 | break; | |
602 | ||
d74b97cc | 603 | case LIBERROR_DIRECT_EOR: |
54f9e278 JD |
604 | p = "Write exceeds length of DIRECT access record"; |
605 | break; | |
606 | ||
d74b97cc | 607 | case LIBERROR_SHORT_RECORD: |
07b3bbf2 | 608 | p = "I/O past end of record on unformatted file"; |
8a7f7fb6 TK |
609 | break; |
610 | ||
d74b97cc | 611 | case LIBERROR_CORRUPT_FILE: |
b4c811bd TK |
612 | p = "Unformatted file structure has been corrupted"; |
613 | break; | |
614 | ||
351b4432 JD |
615 | case LIBERROR_INQUIRE_INTERNAL_UNIT: |
616 | p = "Inquire statement identifies an internal file"; | |
617 | break; | |
618 | ||
6de9cd9a DN |
619 | default: |
620 | p = "Unknown error code"; | |
621 | break; | |
622 | } | |
623 | ||
624 | return p; | |
625 | } | |
626 | ||
627 | ||
2b4c9065 NK |
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. */ | |
6de9cd9a | 630 | |
2b4c9065 NK |
631 | bool |
632 | generate_error_common (st_parameter_common *cmp, int family, const char *message) | |
6de9cd9a | 633 | { |
723553bd | 634 | char errmsg[STRERR_MAXSZ]; |
ceac3d59 | 635 | |
2b4c9065 NK |
636 | #if ASYNC_IO |
637 | gfc_unit *u; | |
638 | ||
639 | NOTE ("Entering generate_error_common"); | |
640 | ||
641 | u = thread_unit; | |
642 | if (u && u->au) | |
643 | { | |
644 | if (u->au->error.has_error) | |
645 | return true; | |
646 | ||
647 | if (__gthread_equal (u->au->thread, __gthread_self ())) | |
648 | { | |
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; | |
653 | return true; | |
654 | } | |
655 | } | |
656 | #endif | |
657 | ||
ceac3d59 TK |
658 | /* If there was a previous error, don't mask it with another |
659 | error message, EOF or EOR condition. */ | |
660 | ||
661 | if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR) | |
2b4c9065 | 662 | return true; |
ceac3d59 | 663 | |
244fada7 | 664 | /* Set the error status. */ |
5e805e44 | 665 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
d74b97cc | 666 | *cmp->iostat = (family == LIBERROR_OS) ? errno : family; |
6de9cd9a | 667 | |
7aba8abe TK |
668 | if (message == NULL) |
669 | message = | |
723553bd JB |
670 | (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) : |
671 | translate_error (family); | |
7aba8abe | 672 | |
5e805e44 JJ |
673 | if (cmp->flags & IOPARM_HAS_IOMSG) |
674 | cf_strcpy (cmp->iomsg, cmp->iomsg_len, message); | |
7aba8abe | 675 | |
244fada7 | 676 | /* Report status back to the compiler. */ |
5e805e44 | 677 | cmp->flags &= ~IOPARM_LIBRETURN_MASK; |
6de9cd9a DN |
678 | switch (family) |
679 | { | |
d74b97cc | 680 | case LIBERROR_EOR: |
2b4c9065 | 681 | cmp->flags |= IOPARM_LIBRETURN_EOR; NOTE("EOR"); |
5e805e44 | 682 | if ((cmp->flags & IOPARM_EOR)) |
2b4c9065 | 683 | return true; |
6de9cd9a DN |
684 | break; |
685 | ||
d74b97cc | 686 | case LIBERROR_END: |
2b4c9065 | 687 | cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END"); |
5e805e44 | 688 | if ((cmp->flags & IOPARM_END)) |
2b4c9065 | 689 | return true; |
6de9cd9a DN |
690 | break; |
691 | ||
692 | default: | |
2b4c9065 | 693 | cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR"); |
5e805e44 | 694 | if ((cmp->flags & IOPARM_ERR)) |
2b4c9065 | 695 | return true; |
6de9cd9a DN |
696 | break; |
697 | } | |
698 | ||
244fada7 | 699 | /* Return if the user supplied an iostat variable. */ |
5e805e44 | 700 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
2b4c9065 | 701 | return true; |
6de9cd9a | 702 | |
2b4c9065 NK |
703 | /* Return code, caller is responsible for terminating |
704 | the program if necessary. */ | |
6de9cd9a | 705 | |
5e805e44 JJ |
706 | recursion_check (); |
707 | show_locus (cmp); | |
edaaef60 JB |
708 | struct iovec iov[3]; |
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"; | |
714 | iov[2].iov_len = 1; | |
715 | estr_writev (iov, 3); | |
2b4c9065 NK |
716 | return false; |
717 | } | |
718 | ||
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. */ | |
728 | ||
729 | void | |
730 | generate_error (st_parameter_common *cmp, int family, const char *message) | |
731 | { | |
732 | if (generate_error_common (cmp, family, message)) | |
733 | return; | |
734 | ||
735 | exit_error(2); | |
6de9cd9a | 736 | } |
cb13c288 | 737 | iexport(generate_error); |
8b67b708 | 738 | |
fc5f5bb7 JD |
739 | |
740 | /* generate_warning()-- Similar to generate_error but just give a warning. */ | |
741 | ||
742 | void | |
743 | generate_warning (st_parameter_common *cmp, const char *message) | |
744 | { | |
745 | if (message == NULL) | |
746 | message = " "; | |
747 | ||
748 | show_locus (cmp); | |
edaaef60 JB |
749 | struct iovec iov[3]; |
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"; | |
755 | iov[2].iov_len = 1; | |
756 | estr_writev (iov, 3); | |
fc5f5bb7 JD |
757 | } |
758 | ||
759 | ||
8f0d39a8 FXC |
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. */ | |
762 | ||
763 | notification | |
764 | notification_std (int std) | |
765 | { | |
766 | int warning; | |
767 | ||
768 | if (!compile_options.pedantic) | |
b2ef02df | 769 | return NOTIFICATION_SILENT; |
8f0d39a8 FXC |
770 | |
771 | warning = compile_options.warn_std & std; | |
772 | if ((compile_options.allow_std & std) != 0 && !warning) | |
b2ef02df | 773 | return NOTIFICATION_SILENT; |
8f0d39a8 | 774 | |
b2ef02df | 775 | return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR; |
8f0d39a8 FXC |
776 | } |
777 | ||
778 | ||
8b67b708 FXC |
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. */ | |
782 | ||
f5e3ed2d | 783 | bool |
2e444427 | 784 | notify_std (st_parameter_common *cmp, int std, const char * message) |
8b67b708 FXC |
785 | { |
786 | int warning; | |
edaaef60 | 787 | struct iovec iov[3]; |
8b67b708 | 788 | |
5f8f5313 | 789 | if (!compile_options.pedantic) |
f5e3ed2d | 790 | return true; |
5f8f5313 | 791 | |
8b67b708 FXC |
792 | warning = compile_options.warn_std & std; |
793 | if ((compile_options.allow_std & std) != 0 && !warning) | |
f5e3ed2d | 794 | return true; |
8b67b708 | 795 | |
8b67b708 FXC |
796 | if (!warning) |
797 | { | |
2e444427 JD |
798 | recursion_check (); |
799 | show_locus (cmp); | |
edaaef60 JB |
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"; | |
805 | iov[2].iov_len = 1; | |
806 | estr_writev (iov, 3); | |
71cda9ca | 807 | exit_error (2); |
8b67b708 FXC |
808 | } |
809 | else | |
2e444427 JD |
810 | { |
811 | show_locus (cmp); | |
edaaef60 JB |
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"; | |
817 | iov[2].iov_len = 1; | |
818 | estr_writev (iov, 3); | |
2e444427 | 819 | } |
f5e3ed2d | 820 | return false; |
8b67b708 | 821 | } |