]>
Commit | Line | Data |
---|---|---|
fbd26352 | 1 | /* Copyright (C) 2002-2019 Free Software Foundation, Inc. |
4ee9c684 | 2 | Contributed by Andy Vaught |
3 | ||
5e62a3cc | 4 | This file is part of the GNU Fortran runtime library (libgfortran). |
4ee9c684 | 5 | |
b417ea8c | 6 | Libgfortran is free software; you can redistribute it and/or modify |
4ee9c684 | 7 | it under the terms of the GNU General Public License as published by |
6bc9506f | 8 | the Free Software Foundation; either version 3, or (at your option) |
4ee9c684 | 9 | any later version. |
10 | ||
b417ea8c | 11 | Libgfortran is distributed in the hope that it will be useful, |
4ee9c684 | 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 | ||
6bc9506f | 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/>. */ | |
4ee9c684 | 24 | |
25 | ||
41f2d5e8 | 26 | #include "libgfortran.h" |
629c30bb | 27 | #include "io.h" |
28 | #include "async.h" | |
29 | ||
556d0269 | 30 | #include <assert.h> |
4ee9c684 | 31 | #include <string.h> |
15c68e22 | 32 | #include <errno.h> |
b7fcd3f9 | 33 | #include <signal.h> |
b7fcd3f9 | 34 | |
35 | #ifdef HAVE_UNISTD_H | |
36 | #include <unistd.h> | |
37 | #endif | |
38 | ||
b7fcd3f9 | 39 | #ifdef HAVE_SYS_TIME_H |
40 | #include <sys/time.h> | |
41 | #endif | |
42 | ||
db019aef | 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 | ||
4ee9c684 | 49 | |
b8a8c7bc | 50 | #include <locale.h> |
51 | ||
52 | #ifdef HAVE_XLOCALE_H | |
53 | #include <xlocale.h> | |
54 | #endif | |
55 | ||
56 | ||
b7fcd3f9 | 57 | #ifdef __MINGW32__ |
58 | #define HAVE_GETPID 1 | |
59 | #include <process.h> | |
60 | #endif | |
61 | ||
62 | ||
b2130263 | 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 | ||
357b7492 | 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. | |
b2130263 | 89 | |
90 | */ | |
b7fcd3f9 | 91 | |
4ee9c684 | 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 | |
4ee9c684 | 102 | * |
103 | * Other error returns are reserved for the STOP statement with a numeric code. | |
104 | */ | |
105 | ||
abe12f3e | 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 | ||
9680a5f4 | 117 | /* Write a vector of strings to standard error. This function is |
118 | async-signal-safe. */ | |
abe12f3e | 119 | |
9680a5f4 | 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 | } | |
abe12f3e | 137 | |
9680a5f4 | 138 | |
139 | #ifndef HAVE_VSNPRINTF | |
140 | static int | |
141 | gf_vsnprintf (char *str, size_t size, const char *format, va_list ap) | |
abe12f3e | 142 | { |
143 | int written; | |
abe12f3e | 144 | |
abe12f3e | 145 | written = vsprintf(buffer, format, ap); |
146 | ||
9680a5f4 | 147 | if (written >= size - 1) |
abe12f3e | 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. */ | |
9680a5f4 | 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)); | |
b2130263 | 155 | sys_abort (); |
abe12f3e | 156 | #undef ERROR_MESSAGE |
157 | ||
158 | } | |
abe12f3e | 159 | return written; |
160 | } | |
161 | ||
9680a5f4 | 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 | |
abe12f3e | 171 | |
172 | int | |
173 | st_printf (const char * format, ...) | |
174 | { | |
9680a5f4 | 175 | char buffer[ST_ERRBUF_SIZE]; |
abe12f3e | 176 | int written; |
177 | va_list ap; | |
178 | va_start (ap, format); | |
9680a5f4 | 179 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, format, ap); |
abe12f3e | 180 | va_end (ap); |
9680a5f4 | 181 | written = write (STDERR_FILENO, buffer, written); |
abe12f3e | 182 | return written; |
183 | } | |
184 | ||
185 | ||
b2130263 | 186 | /* sys_abort()-- Terminate the program showing backtrace and dumping |
187 | core. */ | |
188 | ||
189 | void | |
355846cf | 190 | sys_abort (void) |
b2130263 | 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 | { | |
899edbae | 197 | estr_write ("\nProgram aborted. Backtrace:\n"); |
429cbefb | 198 | show_backtrace (false); |
b2130263 | 199 | signal (SIGABRT, SIG_DFL); |
b2130263 | 200 | } |
201 | ||
202 | abort(); | |
203 | } | |
204 | ||
205 | ||
357b7492 | 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 | ||
e2b80761 | 223 | /* gfc_xtoa()-- Integer to hexadecimal conversion. */ |
4ee9c684 | 224 | |
556d0269 | 225 | const char * |
e2b80761 | 226 | gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) |
4ee9c684 | 227 | { |
228 | int digit; | |
229 | char *p; | |
230 | ||
556d0269 | 231 | assert (len >= GFC_XTOA_BUF_SIZE); |
232 | ||
4ee9c684 | 233 | if (n == 0) |
556d0269 | 234 | return "0"; |
4ee9c684 | 235 | |
556d0269 | 236 | p = buffer + GFC_XTOA_BUF_SIZE - 1; |
237 | *p = '\0'; | |
4ee9c684 | 238 | |
239 | while (n != 0) | |
240 | { | |
241 | digit = n & 0xF; | |
242 | if (digit > 9) | |
243 | digit += 'A' - '0' - 10; | |
244 | ||
556d0269 | 245 | *--p = '0' + digit; |
4ee9c684 | 246 | n >>= 4; |
247 | } | |
248 | ||
556d0269 | 249 | return p; |
4ee9c684 | 250 | } |
251 | ||
4e2562b6 | 252 | |
b8a8c7bc | 253 | /* Hopefully thread-safe wrapper for a strerror() style function. */ |
4e2562b6 | 254 | |
255 | char * | |
256 | gf_strerror (int errnum, | |
257 | char * buf __attribute__((unused)), | |
258 | size_t buflen __attribute__((unused))) | |
259 | { | |
b8a8c7bc | 260 | #ifdef HAVE_STRERROR_L |
261 | locale_t myloc = newlocale (LC_CTYPE_MASK | LC_MESSAGES_MASK, "", | |
262 | (locale_t) 0); | |
429cbefb | 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); | |
b8a8c7bc | 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 | |
a8d8f723 | 281 | /* POSIX returns an "int", GNU a "char*". */ |
7f934e34 | 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)); | |
a8d8f723 | 289 | #elif defined(HAVE_STRERROR_R_2ARGS) |
290 | strerror_r (errnum, buf); | |
291 | return buf; | |
4e2562b6 | 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 | ||
4ee9c684 | 300 | /* show_locus()-- Print a line number and filename describing where |
301 | * something went wrong */ | |
302 | ||
303 | void | |
60c514ba | 304 | show_locus (st_parameter_common *cmp) |
4ee9c684 | 305 | { |
abe12f3e | 306 | char *filename; |
f7f911de | 307 | |
60c514ba | 308 | if (!options.locus || cmp == NULL || cmp->filename == NULL) |
4ee9c684 | 309 | return; |
f7f911de | 310 | |
311 | if (cmp->unit > 0) | |
312 | { | |
313 | filename = filename_from_unit (cmp->unit); | |
abe12f3e | 314 | |
f7f911de | 315 | if (filename != NULL) |
316 | { | |
317 | st_printf ("At line %d of file %s (unit = %d, file = '%s')\n", | |
6af09903 | 318 | (int) cmp->line, cmp->filename, (int) cmp->unit, filename); |
5e62a3cc | 319 | free (filename); |
f7f911de | 320 | } |
6d548e5c | 321 | else |
322 | { | |
323 | st_printf ("At line %d of file %s (unit = %d)\n", | |
6af09903 | 324 | (int) cmp->line, cmp->filename, (int) cmp->unit); |
6d548e5c | 325 | } |
f7f911de | 326 | return; |
327 | } | |
4ee9c684 | 328 | |
21ebda4d | 329 | st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename); |
4ee9c684 | 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 | |
d4ac047b | 335 | * abort immediately. */ |
4ee9c684 | 336 | |
d4ac047b | 337 | static __gthread_key_t recursion_key; |
4ee9c684 | 338 | |
339 | static void | |
340 | recursion_check (void) | |
341 | { | |
d4ac047b | 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 | } | |
4ee9c684 | 362 | |
d4ac047b | 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 | } | |
4ee9c684 | 370 | |
d4ac047b | 371 | static void __attribute__((destructor)) |
372 | destructor_recursion_check (void) | |
373 | { | |
374 | if (__gthread_active_p ()) | |
375 | __gthread_key_delete (recursion_key); | |
4ee9c684 | 376 | } |
d4ac047b | 377 | #endif |
378 | ||
4ee9c684 | 379 | |
380 | ||
4e2562b6 | 381 | #define STRERR_MAXSZ 256 |
382 | ||
4ee9c684 | 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 | { | |
4e2562b6 | 390 | char errmsg[STRERR_MAXSZ]; |
9680a5f4 | 391 | struct iovec iov[5]; |
4ee9c684 | 392 | recursion_check (); |
9680a5f4 | 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); | |
357b7492 | 404 | exit_error (1); |
4ee9c684 | 405 | } |
9915365e | 406 | iexport(os_error); |
4ee9c684 | 407 | |
408 | ||
409 | /* void runtime_error()-- These are errors associated with an | |
410 | * invalid fortran program. */ | |
411 | ||
412 | void | |
5a037dbd | 413 | runtime_error (const char *message, ...) |
4ee9c684 | 414 | { |
9680a5f4 | 415 | char buffer[ST_ERRBUF_SIZE]; |
416 | struct iovec iov[3]; | |
5a037dbd | 417 | va_list ap; |
9680a5f4 | 418 | int written; |
5a037dbd | 419 | |
4ee9c684 | 420 | recursion_check (); |
9680a5f4 | 421 | iov[0].iov_base = (char*) "Fortran runtime error: "; |
422 | iov[0].iov_len = strlen (iov[0].iov_base); | |
5a037dbd | 423 | va_start (ap, message); |
9680a5f4 | 424 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap); |
5a037dbd | 425 | va_end (ap); |
9680a5f4 | 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 | } | |
357b7492 | 434 | exit_error (2); |
4ee9c684 | 435 | } |
7b6cb5bd | 436 | iexport(runtime_error); |
4ee9c684 | 437 | |
13f02ebc | 438 | /* void runtime_error_at()-- These are errors associated with a |
439 | * run time error generated by the front end compiler. */ | |
440 | ||
441 | void | |
399aecc1 | 442 | runtime_error_at (const char *where, const char *message, ...) |
13f02ebc | 443 | { |
9680a5f4 | 444 | char buffer[ST_ERRBUF_SIZE]; |
399aecc1 | 445 | va_list ap; |
9680a5f4 | 446 | struct iovec iov[4]; |
447 | int written; | |
399aecc1 | 448 | |
13f02ebc | 449 | recursion_check (); |
9680a5f4 | 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); | |
399aecc1 | 454 | va_start (ap, message); |
9680a5f4 | 455 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap); |
399aecc1 | 456 | va_end (ap); |
9680a5f4 | 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 | } | |
357b7492 | 465 | exit_error (2); |
13f02ebc | 466 | } |
467 | iexport(runtime_error_at); | |
468 | ||
4ee9c684 | 469 | |
da6ffc6d | 470 | void |
471 | runtime_warning_at (const char *where, const char *message, ...) | |
472 | { | |
9680a5f4 | 473 | char buffer[ST_ERRBUF_SIZE]; |
da6ffc6d | 474 | va_list ap; |
9680a5f4 | 475 | struct iovec iov[4]; |
476 | int written; | |
da6ffc6d | 477 | |
9680a5f4 | 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); | |
da6ffc6d | 482 | va_start (ap, message); |
9680a5f4 | 483 | written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap); |
da6ffc6d | 484 | va_end (ap); |
9680a5f4 | 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 | } | |
da6ffc6d | 493 | } |
494 | iexport(runtime_warning_at); | |
495 | ||
496 | ||
4ee9c684 | 497 | /* void internal_error()-- These are this-can't-happen errors |
498 | * that indicate something deeply wrong. */ | |
499 | ||
500 | void | |
60c514ba | 501 | internal_error (st_parameter_common *cmp, const char *message) |
4ee9c684 | 502 | { |
9680a5f4 | 503 | struct iovec iov[3]; |
504 | ||
4ee9c684 | 505 | recursion_check (); |
60c514ba | 506 | show_locus (cmp); |
9680a5f4 | 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); | |
76875ccb | 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 | ||
357b7492 | 521 | exit_error (3); |
4ee9c684 | 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 | { | |
18f0b7df | 535 | case LIBERROR_EOR: |
4ee9c684 | 536 | p = "End of record"; |
537 | break; | |
538 | ||
18f0b7df | 539 | case LIBERROR_END: |
4ee9c684 | 540 | p = "End of file"; |
541 | break; | |
542 | ||
18f0b7df | 543 | case LIBERROR_OK: |
4ee9c684 | 544 | p = "Successful return"; |
545 | break; | |
546 | ||
18f0b7df | 547 | case LIBERROR_OS: |
4ee9c684 | 548 | p = "Operating system error"; |
549 | break; | |
550 | ||
18f0b7df | 551 | case LIBERROR_BAD_OPTION: |
4ee9c684 | 552 | p = "Bad statement option"; |
553 | break; | |
554 | ||
18f0b7df | 555 | case LIBERROR_MISSING_OPTION: |
4ee9c684 | 556 | p = "Missing statement option"; |
557 | break; | |
558 | ||
18f0b7df | 559 | case LIBERROR_OPTION_CONFLICT: |
4ee9c684 | 560 | p = "Conflicting statement options"; |
561 | break; | |
562 | ||
18f0b7df | 563 | case LIBERROR_ALREADY_OPEN: |
4ee9c684 | 564 | p = "File already opened in another unit"; |
565 | break; | |
566 | ||
18f0b7df | 567 | case LIBERROR_BAD_UNIT: |
4ee9c684 | 568 | p = "Unattached unit"; |
569 | break; | |
570 | ||
18f0b7df | 571 | case LIBERROR_FORMAT: |
4ee9c684 | 572 | p = "FORMAT error"; |
573 | break; | |
574 | ||
18f0b7df | 575 | case LIBERROR_BAD_ACTION: |
4ee9c684 | 576 | p = "Incorrect ACTION specified"; |
577 | break; | |
578 | ||
18f0b7df | 579 | case LIBERROR_ENDFILE: |
4ee9c684 | 580 | p = "Read past ENDFILE record"; |
581 | break; | |
582 | ||
18f0b7df | 583 | case LIBERROR_BAD_US: |
4ee9c684 | 584 | p = "Corrupt unformatted sequential file"; |
585 | break; | |
586 | ||
18f0b7df | 587 | case LIBERROR_READ_VALUE: |
4ee9c684 | 588 | p = "Bad value during read"; |
589 | break; | |
590 | ||
18f0b7df | 591 | case LIBERROR_READ_OVERFLOW: |
4ee9c684 | 592 | p = "Numeric overflow on read"; |
593 | break; | |
594 | ||
18f0b7df | 595 | case LIBERROR_INTERNAL: |
8c39329b | 596 | p = "Internal error in run-time library"; |
597 | break; | |
598 | ||
18f0b7df | 599 | case LIBERROR_INTERNAL_UNIT: |
8c39329b | 600 | p = "Internal unit I/O error"; |
601 | break; | |
602 | ||
18f0b7df | 603 | case LIBERROR_DIRECT_EOR: |
b65a66ea | 604 | p = "Write exceeds length of DIRECT access record"; |
605 | break; | |
606 | ||
18f0b7df | 607 | case LIBERROR_SHORT_RECORD: |
bbaaa7b1 | 608 | p = "I/O past end of record on unformatted file"; |
c0e176b5 | 609 | break; |
610 | ||
18f0b7df | 611 | case LIBERROR_CORRUPT_FILE: |
71b43437 | 612 | p = "Unformatted file structure has been corrupted"; |
613 | break; | |
614 | ||
64c7e3f7 | 615 | case LIBERROR_INQUIRE_INTERNAL_UNIT: |
616 | p = "Inquire statement identifies an internal file"; | |
617 | break; | |
618 | ||
4ee9c684 | 619 | default: |
620 | p = "Unknown error code"; | |
621 | break; | |
622 | } | |
623 | ||
624 | return p; | |
625 | } | |
626 | ||
627 | ||
629c30bb | 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. */ | |
4ee9c684 | 630 | |
629c30bb | 631 | bool |
632 | generate_error_common (st_parameter_common *cmp, int family, const char *message) | |
4ee9c684 | 633 | { |
4e2562b6 | 634 | char errmsg[STRERR_MAXSZ]; |
d5bf8d02 | 635 | |
629c30bb | 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 | ||
d5bf8d02 | 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) | |
629c30bb | 662 | return true; |
d5bf8d02 | 663 | |
4cab09cb | 664 | /* Set the error status. */ |
60c514ba | 665 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
18f0b7df | 666 | *cmp->iostat = (family == LIBERROR_OS) ? errno : family; |
4ee9c684 | 667 | |
65f9e5fc | 668 | if (message == NULL) |
669 | message = | |
4e2562b6 | 670 | (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) : |
671 | translate_error (family); | |
65f9e5fc | 672 | |
60c514ba | 673 | if (cmp->flags & IOPARM_HAS_IOMSG) |
674 | cf_strcpy (cmp->iomsg, cmp->iomsg_len, message); | |
65f9e5fc | 675 | |
4cab09cb | 676 | /* Report status back to the compiler. */ |
60c514ba | 677 | cmp->flags &= ~IOPARM_LIBRETURN_MASK; |
4ee9c684 | 678 | switch (family) |
679 | { | |
18f0b7df | 680 | case LIBERROR_EOR: |
629c30bb | 681 | cmp->flags |= IOPARM_LIBRETURN_EOR; NOTE("EOR"); |
60c514ba | 682 | if ((cmp->flags & IOPARM_EOR)) |
629c30bb | 683 | return true; |
4ee9c684 | 684 | break; |
685 | ||
18f0b7df | 686 | case LIBERROR_END: |
629c30bb | 687 | cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END"); |
60c514ba | 688 | if ((cmp->flags & IOPARM_END)) |
629c30bb | 689 | return true; |
4ee9c684 | 690 | break; |
691 | ||
692 | default: | |
629c30bb | 693 | cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR"); |
60c514ba | 694 | if ((cmp->flags & IOPARM_ERR)) |
629c30bb | 695 | return true; |
4ee9c684 | 696 | break; |
697 | } | |
698 | ||
4cab09cb | 699 | /* Return if the user supplied an iostat variable. */ |
60c514ba | 700 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
629c30bb | 701 | return true; |
4ee9c684 | 702 | |
629c30bb | 703 | /* Return code, caller is responsible for terminating |
704 | the program if necessary. */ | |
4ee9c684 | 705 | |
60c514ba | 706 | recursion_check (); |
707 | show_locus (cmp); | |
9680a5f4 | 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); | |
629c30bb | 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); | |
4ee9c684 | 736 | } |
13f02ebc | 737 | iexport(generate_error); |
64fc3c4c | 738 | |
6a06f1b6 | 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); | |
9680a5f4 | 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); | |
6a06f1b6 | 757 | } |
758 | ||
759 | ||
158f58e7 | 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) | |
c08106d1 | 769 | return NOTIFICATION_SILENT; |
158f58e7 | 770 | |
771 | warning = compile_options.warn_std & std; | |
772 | if ((compile_options.allow_std & std) != 0 && !warning) | |
c08106d1 | 773 | return NOTIFICATION_SILENT; |
158f58e7 | 774 | |
c08106d1 | 775 | return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR; |
158f58e7 | 776 | } |
777 | ||
778 | ||
64fc3c4c | 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 | ||
aad89ecf | 783 | bool |
02183b45 | 784 | notify_std (st_parameter_common *cmp, int std, const char * message) |
64fc3c4c | 785 | { |
786 | int warning; | |
9680a5f4 | 787 | struct iovec iov[3]; |
64fc3c4c | 788 | |
7833ddd7 | 789 | if (!compile_options.pedantic) |
aad89ecf | 790 | return true; |
7833ddd7 | 791 | |
64fc3c4c | 792 | warning = compile_options.warn_std & std; |
793 | if ((compile_options.allow_std & std) != 0 && !warning) | |
aad89ecf | 794 | return true; |
64fc3c4c | 795 | |
64fc3c4c | 796 | if (!warning) |
797 | { | |
02183b45 | 798 | recursion_check (); |
799 | show_locus (cmp); | |
9680a5f4 | 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); | |
357b7492 | 807 | exit_error (2); |
64fc3c4c | 808 | } |
809 | else | |
02183b45 | 810 | { |
811 | show_locus (cmp); | |
9680a5f4 | 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); | |
02183b45 | 819 | } |
aad89ecf | 820 | return false; |
64fc3c4c | 821 | } |