]>
Commit | Line | Data |
---|---|---|
1 | /* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009, 2010, 2011 | |
2 | Free Software Foundation, Inc. | |
3 | Contributed by Andy Vaught | |
4 | ||
5 | This file is part of the GNU Fortran runtime library (libgfortran). | |
6 | ||
7 | Libgfortran is free software; you can redistribute it and/or modify | |
8 | it under the terms of the GNU General Public License as published by | |
9 | the Free Software Foundation; either version 3, or (at your option) | |
10 | any later version. | |
11 | ||
12 | Libgfortran is distributed in the hope that it will be useful, | |
13 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | GNU General Public License for more details. | |
16 | ||
17 | Under Section 7 of GPL version 3, you are granted additional | |
18 | permissions described in the GCC Runtime Library Exception, version | |
19 | 3.1, as published by the Free Software Foundation. | |
20 | ||
21 | You should have received a copy of the GNU General Public License and | |
22 | a copy of the GCC Runtime Library Exception along with this program; | |
23 | see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
24 | <http://www.gnu.org/licenses/>. */ | |
25 | ||
26 | ||
27 | #include "libgfortran.h" | |
28 | #include <assert.h> | |
29 | #include <string.h> | |
30 | #include <errno.h> | |
31 | #include <signal.h> | |
32 | ||
33 | #ifdef HAVE_UNISTD_H | |
34 | #include <unistd.h> | |
35 | #endif | |
36 | ||
37 | #include <stdlib.h> | |
38 | ||
39 | #ifdef HAVE_SYS_TIME_H | |
40 | #include <sys/time.h> | |
41 | #endif | |
42 | ||
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 | ||
49 | ||
50 | #ifdef __MINGW32__ | |
51 | #define HAVE_GETPID 1 | |
52 | #include <process.h> | |
53 | #endif | |
54 | ||
55 | ||
56 | /* Termination of a program: F2008 2.3.5 talks about "normal | |
57 | termination" and "error termination". Normal termination occurs as | |
58 | a result of e.g. executing the end program statement, and executing | |
59 | the STOP statement. It includes the effect of the C exit() | |
60 | function. | |
61 | ||
62 | Error termination is initiated when the ERROR STOP statement is | |
63 | executed, when ALLOCATE/DEALLOCATE fails without STAT= being | |
64 | specified, when some of the co-array synchronization statements | |
65 | fail without STAT= being specified, and some I/O errors if | |
66 | ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE | |
67 | failure without CMDSTAT=. | |
68 | ||
69 | 2.3.5 also explains how co-images synchronize during termination. | |
70 | ||
71 | In libgfortran we have two ways of ending a program. exit(code) is | |
72 | a normal exit; calling exit() also causes open units to be | |
73 | closed. No backtrace or core dump is needed here. When something | |
74 | goes wrong, we have sys_abort() which tries to print the backtrace | |
75 | if -fbacktrace is enabled, and then dumps core; whether a core file | |
76 | is generated is system dependent. When aborting, we don't flush and | |
77 | close open units, as program memory might be corrupted and we'd | |
78 | rather risk losing dirty data in the buffers rather than corrupting | |
79 | files on disk. | |
80 | ||
81 | */ | |
82 | ||
83 | /* Error conditions. The tricky part here is printing a message when | |
84 | * it is the I/O subsystem that is severely wounded. Our goal is to | |
85 | * try and print something making the fewest assumptions possible, | |
86 | * then try to clean up before actually exiting. | |
87 | * | |
88 | * The following exit conditions are defined: | |
89 | * 0 Normal program exit. | |
90 | * 1 Terminated because of operating system error. | |
91 | * 2 Error in the runtime library | |
92 | * 3 Internal error in runtime library | |
93 | * | |
94 | * Other error returns are reserved for the STOP statement with a numeric code. | |
95 | */ | |
96 | ||
97 | ||
98 | /* Write a null-terminated C string to standard error. This function | |
99 | is async-signal-safe. */ | |
100 | ||
101 | ssize_t | |
102 | estr_write (const char *str) | |
103 | { | |
104 | return write (STDERR_FILENO, str, strlen (str)); | |
105 | } | |
106 | ||
107 | ||
108 | /* st_vprintf()-- vsnprintf-like function for error output. We use a | |
109 | stack allocated buffer for formatting; since this function might be | |
110 | called from within a signal handler, printing directly to stderr | |
111 | with vfprintf is not safe since the stderr locking might lead to a | |
112 | deadlock. */ | |
113 | ||
114 | #define ST_VPRINTF_SIZE 512 | |
115 | ||
116 | int | |
117 | st_vprintf (const char *format, va_list ap) | |
118 | { | |
119 | int written; | |
120 | char buffer[ST_VPRINTF_SIZE]; | |
121 | ||
122 | #ifdef HAVE_VSNPRINTF | |
123 | written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap); | |
124 | #else | |
125 | written = vsprintf(buffer, format, ap); | |
126 | ||
127 | if (written >= ST_VPRINTF_SIZE - 1) | |
128 | { | |
129 | /* The error message was longer than our buffer. Ouch. Because | |
130 | we may have messed up things badly, report the error and | |
131 | quit. */ | |
132 | #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n" | |
133 | write (STDERR_FILENO, buffer, ST_VPRINTF_SIZE - 1); | |
134 | write (STDERR_FILENO, ERROR_MESSAGE, strlen(ERROR_MESSAGE)); | |
135 | sys_abort (); | |
136 | #undef ERROR_MESSAGE | |
137 | ||
138 | } | |
139 | #endif | |
140 | ||
141 | written = write (STDERR_FILENO, buffer, written); | |
142 | return written; | |
143 | } | |
144 | ||
145 | ||
146 | int | |
147 | st_printf (const char * format, ...) | |
148 | { | |
149 | int written; | |
150 | va_list ap; | |
151 | va_start (ap, format); | |
152 | written = st_vprintf (format, ap); | |
153 | va_end (ap); | |
154 | return written; | |
155 | } | |
156 | ||
157 | ||
158 | /* sys_abort()-- Terminate the program showing backtrace and dumping | |
159 | core. */ | |
160 | ||
161 | void | |
162 | sys_abort (void) | |
163 | { | |
164 | /* If backtracing is enabled, print backtrace and disable signal | |
165 | handler for ABRT. */ | |
166 | if (options.backtrace == 1 | |
167 | || (options.backtrace == -1 && compile_options.backtrace == 1)) | |
168 | { | |
169 | show_backtrace (); | |
170 | signal (SIGABRT, SIG_DFL); | |
171 | } | |
172 | ||
173 | abort(); | |
174 | } | |
175 | ||
176 | ||
177 | /* gfc_xtoa()-- Integer to hexadecimal conversion. */ | |
178 | ||
179 | const char * | |
180 | gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) | |
181 | { | |
182 | int digit; | |
183 | char *p; | |
184 | ||
185 | assert (len >= GFC_XTOA_BUF_SIZE); | |
186 | ||
187 | if (n == 0) | |
188 | return "0"; | |
189 | ||
190 | p = buffer + GFC_XTOA_BUF_SIZE - 1; | |
191 | *p = '\0'; | |
192 | ||
193 | while (n != 0) | |
194 | { | |
195 | digit = n & 0xF; | |
196 | if (digit > 9) | |
197 | digit += 'A' - '0' - 10; | |
198 | ||
199 | *--p = '0' + digit; | |
200 | n >>= 4; | |
201 | } | |
202 | ||
203 | return p; | |
204 | } | |
205 | ||
206 | ||
207 | /* Hopefully thread-safe wrapper for a strerror_r() style function. */ | |
208 | ||
209 | char * | |
210 | gf_strerror (int errnum, | |
211 | char * buf __attribute__((unused)), | |
212 | size_t buflen __attribute__((unused))) | |
213 | { | |
214 | #ifdef HAVE_STRERROR_R | |
215 | return | |
216 | __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0)) | |
217 | == 5, | |
218 | /* GNU strerror_r() */ | |
219 | strerror_r (errnum, buf, buflen), | |
220 | /* POSIX strerror_r () */ | |
221 | (strerror_r (errnum, buf, buflen), buf)); | |
222 | #else | |
223 | /* strerror () is not necessarily thread-safe, but should at least | |
224 | be available everywhere. */ | |
225 | return strerror (errnum); | |
226 | #endif | |
227 | } | |
228 | ||
229 | ||
230 | /* show_locus()-- Print a line number and filename describing where | |
231 | * something went wrong */ | |
232 | ||
233 | void | |
234 | show_locus (st_parameter_common *cmp) | |
235 | { | |
236 | char *filename; | |
237 | ||
238 | if (!options.locus || cmp == NULL || cmp->filename == NULL) | |
239 | return; | |
240 | ||
241 | if (cmp->unit > 0) | |
242 | { | |
243 | filename = filename_from_unit (cmp->unit); | |
244 | ||
245 | if (filename != NULL) | |
246 | { | |
247 | st_printf ("At line %d of file %s (unit = %d, file = '%s')\n", | |
248 | (int) cmp->line, cmp->filename, (int) cmp->unit, filename); | |
249 | free (filename); | |
250 | } | |
251 | else | |
252 | { | |
253 | st_printf ("At line %d of file %s (unit = %d)\n", | |
254 | (int) cmp->line, cmp->filename, (int) cmp->unit); | |
255 | } | |
256 | return; | |
257 | } | |
258 | ||
259 | st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename); | |
260 | } | |
261 | ||
262 | ||
263 | /* recursion_check()-- It's possible for additional errors to occur | |
264 | * during fatal error processing. We detect this condition here and | |
265 | * exit with code 4 immediately. */ | |
266 | ||
267 | #define MAGIC 0x20DE8101 | |
268 | ||
269 | static void | |
270 | recursion_check (void) | |
271 | { | |
272 | static int magic = 0; | |
273 | ||
274 | /* Don't even try to print something at this point */ | |
275 | if (magic == MAGIC) | |
276 | sys_abort (); | |
277 | ||
278 | magic = MAGIC; | |
279 | } | |
280 | ||
281 | ||
282 | #define STRERR_MAXSZ 256 | |
283 | ||
284 | /* os_error()-- Operating system error. We get a message from the | |
285 | * operating system, show it and leave. Some operating system errors | |
286 | * are caught and processed by the library. If not, we come here. */ | |
287 | ||
288 | void | |
289 | os_error (const char *message) | |
290 | { | |
291 | char errmsg[STRERR_MAXSZ]; | |
292 | recursion_check (); | |
293 | estr_write ("Operating system error: "); | |
294 | estr_write (gf_strerror (errno, errmsg, STRERR_MAXSZ)); | |
295 | estr_write ("\n"); | |
296 | estr_write (message); | |
297 | estr_write ("\n"); | |
298 | exit (1); | |
299 | } | |
300 | iexport(os_error); | |
301 | ||
302 | ||
303 | /* void runtime_error()-- These are errors associated with an | |
304 | * invalid fortran program. */ | |
305 | ||
306 | void | |
307 | runtime_error (const char *message, ...) | |
308 | { | |
309 | va_list ap; | |
310 | ||
311 | recursion_check (); | |
312 | estr_write ("Fortran runtime error: "); | |
313 | va_start (ap, message); | |
314 | st_vprintf (message, ap); | |
315 | va_end (ap); | |
316 | estr_write ("\n"); | |
317 | exit (2); | |
318 | } | |
319 | iexport(runtime_error); | |
320 | ||
321 | /* void runtime_error_at()-- These are errors associated with a | |
322 | * run time error generated by the front end compiler. */ | |
323 | ||
324 | void | |
325 | runtime_error_at (const char *where, const char *message, ...) | |
326 | { | |
327 | va_list ap; | |
328 | ||
329 | recursion_check (); | |
330 | estr_write (where); | |
331 | estr_write ("\nFortran runtime error: "); | |
332 | va_start (ap, message); | |
333 | st_vprintf (message, ap); | |
334 | va_end (ap); | |
335 | estr_write ("\n"); | |
336 | exit (2); | |
337 | } | |
338 | iexport(runtime_error_at); | |
339 | ||
340 | ||
341 | void | |
342 | runtime_warning_at (const char *where, const char *message, ...) | |
343 | { | |
344 | va_list ap; | |
345 | ||
346 | estr_write (where); | |
347 | estr_write ("\nFortran runtime warning: "); | |
348 | va_start (ap, message); | |
349 | st_vprintf (message, ap); | |
350 | va_end (ap); | |
351 | estr_write ("\n"); | |
352 | } | |
353 | iexport(runtime_warning_at); | |
354 | ||
355 | ||
356 | /* void internal_error()-- These are this-can't-happen errors | |
357 | * that indicate something deeply wrong. */ | |
358 | ||
359 | void | |
360 | internal_error (st_parameter_common *cmp, const char *message) | |
361 | { | |
362 | recursion_check (); | |
363 | show_locus (cmp); | |
364 | estr_write ("Internal Error: "); | |
365 | estr_write (message); | |
366 | estr_write ("\n"); | |
367 | ||
368 | /* This function call is here to get the main.o object file included | |
369 | when linking statically. This works because error.o is supposed to | |
370 | be always linked in (and the function call is in internal_error | |
371 | because hopefully it doesn't happen too often). */ | |
372 | stupid_function_name_for_static_linking(); | |
373 | ||
374 | exit (3); | |
375 | } | |
376 | ||
377 | ||
378 | /* translate_error()-- Given an integer error code, return a string | |
379 | * describing the error. */ | |
380 | ||
381 | const char * | |
382 | translate_error (int code) | |
383 | { | |
384 | const char *p; | |
385 | ||
386 | switch (code) | |
387 | { | |
388 | case LIBERROR_EOR: | |
389 | p = "End of record"; | |
390 | break; | |
391 | ||
392 | case LIBERROR_END: | |
393 | p = "End of file"; | |
394 | break; | |
395 | ||
396 | case LIBERROR_OK: | |
397 | p = "Successful return"; | |
398 | break; | |
399 | ||
400 | case LIBERROR_OS: | |
401 | p = "Operating system error"; | |
402 | break; | |
403 | ||
404 | case LIBERROR_BAD_OPTION: | |
405 | p = "Bad statement option"; | |
406 | break; | |
407 | ||
408 | case LIBERROR_MISSING_OPTION: | |
409 | p = "Missing statement option"; | |
410 | break; | |
411 | ||
412 | case LIBERROR_OPTION_CONFLICT: | |
413 | p = "Conflicting statement options"; | |
414 | break; | |
415 | ||
416 | case LIBERROR_ALREADY_OPEN: | |
417 | p = "File already opened in another unit"; | |
418 | break; | |
419 | ||
420 | case LIBERROR_BAD_UNIT: | |
421 | p = "Unattached unit"; | |
422 | break; | |
423 | ||
424 | case LIBERROR_FORMAT: | |
425 | p = "FORMAT error"; | |
426 | break; | |
427 | ||
428 | case LIBERROR_BAD_ACTION: | |
429 | p = "Incorrect ACTION specified"; | |
430 | break; | |
431 | ||
432 | case LIBERROR_ENDFILE: | |
433 | p = "Read past ENDFILE record"; | |
434 | break; | |
435 | ||
436 | case LIBERROR_BAD_US: | |
437 | p = "Corrupt unformatted sequential file"; | |
438 | break; | |
439 | ||
440 | case LIBERROR_READ_VALUE: | |
441 | p = "Bad value during read"; | |
442 | break; | |
443 | ||
444 | case LIBERROR_READ_OVERFLOW: | |
445 | p = "Numeric overflow on read"; | |
446 | break; | |
447 | ||
448 | case LIBERROR_INTERNAL: | |
449 | p = "Internal error in run-time library"; | |
450 | break; | |
451 | ||
452 | case LIBERROR_INTERNAL_UNIT: | |
453 | p = "Internal unit I/O error"; | |
454 | break; | |
455 | ||
456 | case LIBERROR_DIRECT_EOR: | |
457 | p = "Write exceeds length of DIRECT access record"; | |
458 | break; | |
459 | ||
460 | case LIBERROR_SHORT_RECORD: | |
461 | p = "I/O past end of record on unformatted file"; | |
462 | break; | |
463 | ||
464 | case LIBERROR_CORRUPT_FILE: | |
465 | p = "Unformatted file structure has been corrupted"; | |
466 | break; | |
467 | ||
468 | default: | |
469 | p = "Unknown error code"; | |
470 | break; | |
471 | } | |
472 | ||
473 | return p; | |
474 | } | |
475 | ||
476 | ||
477 | /* generate_error()-- Come here when an error happens. This | |
478 | * subroutine is called if it is possible to continue on after the error. | |
479 | * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or | |
480 | * ERR labels are present, we return, otherwise we terminate the program | |
481 | * after printing a message. The error code is always required but the | |
482 | * message parameter can be NULL, in which case a string describing | |
483 | * the most recent operating system error is used. */ | |
484 | ||
485 | void | |
486 | generate_error (st_parameter_common *cmp, int family, const char *message) | |
487 | { | |
488 | char errmsg[STRERR_MAXSZ]; | |
489 | ||
490 | /* If there was a previous error, don't mask it with another | |
491 | error message, EOF or EOR condition. */ | |
492 | ||
493 | if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR) | |
494 | return; | |
495 | ||
496 | /* Set the error status. */ | |
497 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) | |
498 | *cmp->iostat = (family == LIBERROR_OS) ? errno : family; | |
499 | ||
500 | if (message == NULL) | |
501 | message = | |
502 | (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) : | |
503 | translate_error (family); | |
504 | ||
505 | if (cmp->flags & IOPARM_HAS_IOMSG) | |
506 | cf_strcpy (cmp->iomsg, cmp->iomsg_len, message); | |
507 | ||
508 | /* Report status back to the compiler. */ | |
509 | cmp->flags &= ~IOPARM_LIBRETURN_MASK; | |
510 | switch (family) | |
511 | { | |
512 | case LIBERROR_EOR: | |
513 | cmp->flags |= IOPARM_LIBRETURN_EOR; | |
514 | if ((cmp->flags & IOPARM_EOR)) | |
515 | return; | |
516 | break; | |
517 | ||
518 | case LIBERROR_END: | |
519 | cmp->flags |= IOPARM_LIBRETURN_END; | |
520 | if ((cmp->flags & IOPARM_END)) | |
521 | return; | |
522 | break; | |
523 | ||
524 | default: | |
525 | cmp->flags |= IOPARM_LIBRETURN_ERROR; | |
526 | if ((cmp->flags & IOPARM_ERR)) | |
527 | return; | |
528 | break; | |
529 | } | |
530 | ||
531 | /* Return if the user supplied an iostat variable. */ | |
532 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) | |
533 | return; | |
534 | ||
535 | /* Terminate the program */ | |
536 | ||
537 | recursion_check (); | |
538 | show_locus (cmp); | |
539 | estr_write ("Fortran runtime error: "); | |
540 | estr_write (message); | |
541 | estr_write ("\n"); | |
542 | exit (2); | |
543 | } | |
544 | iexport(generate_error); | |
545 | ||
546 | ||
547 | /* generate_warning()-- Similar to generate_error but just give a warning. */ | |
548 | ||
549 | void | |
550 | generate_warning (st_parameter_common *cmp, const char *message) | |
551 | { | |
552 | if (message == NULL) | |
553 | message = " "; | |
554 | ||
555 | show_locus (cmp); | |
556 | estr_write ("Fortran runtime warning: "); | |
557 | estr_write (message); | |
558 | estr_write ("\n"); | |
559 | } | |
560 | ||
561 | ||
562 | /* Whether, for a feature included in a given standard set (GFC_STD_*), | |
563 | we should issue an error or a warning, or be quiet. */ | |
564 | ||
565 | notification | |
566 | notification_std (int std) | |
567 | { | |
568 | int warning; | |
569 | ||
570 | if (!compile_options.pedantic) | |
571 | return NOTIFICATION_SILENT; | |
572 | ||
573 | warning = compile_options.warn_std & std; | |
574 | if ((compile_options.allow_std & std) != 0 && !warning) | |
575 | return NOTIFICATION_SILENT; | |
576 | ||
577 | return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR; | |
578 | } | |
579 | ||
580 | ||
581 | /* Possibly issue a warning/error about use of a nonstandard (or deleted) | |
582 | feature. An error/warning will be issued if the currently selected | |
583 | standard does not contain the requested bits. */ | |
584 | ||
585 | try | |
586 | notify_std (st_parameter_common *cmp, int std, const char * message) | |
587 | { | |
588 | int warning; | |
589 | ||
590 | if (!compile_options.pedantic) | |
591 | return SUCCESS; | |
592 | ||
593 | warning = compile_options.warn_std & std; | |
594 | if ((compile_options.allow_std & std) != 0 && !warning) | |
595 | return SUCCESS; | |
596 | ||
597 | if (!warning) | |
598 | { | |
599 | recursion_check (); | |
600 | show_locus (cmp); | |
601 | estr_write ("Fortran runtime error: "); | |
602 | estr_write (message); | |
603 | estr_write ("\n"); | |
604 | exit (2); | |
605 | } | |
606 | else | |
607 | { | |
608 | show_locus (cmp); | |
609 | estr_write ("Fortran runtime warning: "); | |
610 | estr_write (message); | |
611 | estr_write ("\n"); | |
612 | } | |
613 | return FAILURE; | |
614 | } |