]>
Commit | Line | Data |
---|---|---|
a1ff2ab8 | 1 | /* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009, 2010 |
748086b7 | 2 | Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Andy Vaught |
4 | ||
bb408e87 | 5 | This file is part of the GNU Fortran runtime library (libgfortran). |
6de9cd9a | 6 | |
57dea9f6 | 7 | Libgfortran is free software; you can redistribute it and/or modify |
6de9cd9a | 8 | it under the terms of the GNU General Public License as published by |
748086b7 | 9 | the Free Software Foundation; either version 3, or (at your option) |
6de9cd9a DN |
10 | any later version. |
11 | ||
57dea9f6 | 12 | Libgfortran is distributed in the hope that it will be useful, |
6de9cd9a DN |
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 | ||
748086b7 JJ |
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/>. */ | |
6de9cd9a DN |
25 | |
26 | ||
36ae8a61 | 27 | #include "libgfortran.h" |
1449b8cb | 28 | #include <assert.h> |
6de9cd9a | 29 | #include <string.h> |
4a8bce89 | 30 | #include <errno.h> |
6de9cd9a | 31 | |
eedeea04 FXC |
32 | #ifdef HAVE_SIGNAL_H |
33 | #include <signal.h> | |
34 | #endif | |
35 | ||
36 | #ifdef HAVE_UNISTD_H | |
37 | #include <unistd.h> | |
38 | #endif | |
39 | ||
40 | #ifdef HAVE_STDLIB_H | |
41 | #include <stdlib.h> | |
42 | #endif | |
43 | ||
eedeea04 FXC |
44 | #ifdef HAVE_SYS_TIME_H |
45 | #include <sys/time.h> | |
46 | #endif | |
47 | ||
f64acab6 FXC |
48 | /* <sys/time.h> has to be included before <sys/resource.h> to work |
49 | around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */ | |
50 | #ifdef HAVE_SYS_RESOURCE_H | |
51 | #include <sys/resource.h> | |
52 | #endif | |
53 | ||
6de9cd9a | 54 | |
eedeea04 FXC |
55 | #ifdef __MINGW32__ |
56 | #define HAVE_GETPID 1 | |
57 | #include <process.h> | |
58 | #endif | |
59 | ||
60 | ||
61 | /* sys_exit()-- Terminate the program with an exit code. */ | |
62 | ||
63 | void | |
64 | sys_exit (int code) | |
65 | { | |
868d75db FXC |
66 | /* Show error backtrace if possible. */ |
67 | if (code != 0 && code != 4 | |
68 | && (options.backtrace == 1 | |
69 | || (options.backtrace == -1 && compile_options.backtrace == 1))) | |
70 | show_backtrace (); | |
71 | ||
eedeea04 FXC |
72 | /* Dump core if requested. */ |
73 | if (code != 0 | |
74 | && (options.dump_core == 1 | |
75 | || (options.dump_core == -1 && compile_options.dump_core == 1))) | |
76 | { | |
77 | #if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE) | |
78 | /* Warn if a core file cannot be produced because | |
79 | of core size limit. */ | |
80 | ||
81 | struct rlimit core_limit; | |
82 | ||
83 | if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0) | |
84 | st_printf ("** Warning: a core dump was requested, but the core size" | |
85 | "limit\n** is currently zero.\n\n"); | |
86 | #endif | |
87 | ||
88 | ||
89 | #if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT) | |
90 | kill (getpid (), SIGQUIT); | |
91 | #else | |
92 | st_printf ("Core dump not possible, sorry."); | |
93 | #endif | |
94 | } | |
95 | ||
96 | exit (code); | |
97 | } | |
98 | ||
99 | ||
6de9cd9a DN |
100 | /* Error conditions. The tricky part here is printing a message when |
101 | * it is the I/O subsystem that is severely wounded. Our goal is to | |
102 | * try and print something making the fewest assumptions possible, | |
103 | * then try to clean up before actually exiting. | |
104 | * | |
105 | * The following exit conditions are defined: | |
106 | * 0 Normal program exit. | |
107 | * 1 Terminated because of operating system error. | |
108 | * 2 Error in the runtime library | |
109 | * 3 Internal error in runtime library | |
110 | * 4 Error during error processing (very bad) | |
111 | * | |
112 | * Other error returns are reserved for the STOP statement with a numeric code. | |
113 | */ | |
114 | ||
f9bfed22 | 115 | /* gfc_xtoa()-- Integer to hexadecimal conversion. */ |
6de9cd9a | 116 | |
1449b8cb | 117 | const char * |
f9bfed22 | 118 | gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) |
6de9cd9a DN |
119 | { |
120 | int digit; | |
121 | char *p; | |
122 | ||
1449b8cb JJ |
123 | assert (len >= GFC_XTOA_BUF_SIZE); |
124 | ||
6de9cd9a | 125 | if (n == 0) |
1449b8cb | 126 | return "0"; |
6de9cd9a | 127 | |
1449b8cb JJ |
128 | p = buffer + GFC_XTOA_BUF_SIZE - 1; |
129 | *p = '\0'; | |
6de9cd9a DN |
130 | |
131 | while (n != 0) | |
132 | { | |
133 | digit = n & 0xF; | |
134 | if (digit > 9) | |
135 | digit += 'A' - '0' - 10; | |
136 | ||
1449b8cb | 137 | *--p = '0' + digit; |
6de9cd9a DN |
138 | n >>= 4; |
139 | } | |
140 | ||
1449b8cb | 141 | return p; |
6de9cd9a DN |
142 | } |
143 | ||
6de9cd9a DN |
144 | /* show_locus()-- Print a line number and filename describing where |
145 | * something went wrong */ | |
146 | ||
147 | void | |
5e805e44 | 148 | show_locus (st_parameter_common *cmp) |
6de9cd9a | 149 | { |
87557722 JD |
150 | static char *filename; |
151 | ||
5e805e44 | 152 | if (!options.locus || cmp == NULL || cmp->filename == NULL) |
6de9cd9a | 153 | return; |
87557722 JD |
154 | |
155 | if (cmp->unit > 0) | |
156 | { | |
157 | filename = filename_from_unit (cmp->unit); | |
158 | if (filename != NULL) | |
159 | { | |
160 | st_printf ("At line %d of file %s (unit = %d, file = '%s')\n", | |
4e2eb53c | 161 | (int) cmp->line, cmp->filename, (int) cmp->unit, filename); |
bb408e87 | 162 | free (filename); |
87557722 | 163 | } |
c26cc9a6 JD |
164 | else |
165 | { | |
166 | st_printf ("At line %d of file %s (unit = %d)\n", | |
4e2eb53c | 167 | (int) cmp->line, cmp->filename, (int) cmp->unit); |
c26cc9a6 | 168 | } |
87557722 JD |
169 | return; |
170 | } | |
6de9cd9a | 171 | |
6c0e51c4 | 172 | st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename); |
6de9cd9a DN |
173 | } |
174 | ||
175 | ||
176 | /* recursion_check()-- It's possible for additional errors to occur | |
177 | * during fatal error processing. We detect this condition here and | |
178 | * exit with code 4 immediately. */ | |
179 | ||
180 | #define MAGIC 0x20DE8101 | |
181 | ||
182 | static void | |
183 | recursion_check (void) | |
184 | { | |
185 | static int magic = 0; | |
186 | ||
f21edfd6 | 187 | /* Don't even try to print something at this point */ |
6de9cd9a | 188 | if (magic == MAGIC) |
f21edfd6 | 189 | sys_exit (4); |
6de9cd9a DN |
190 | |
191 | magic = MAGIC; | |
192 | } | |
193 | ||
194 | ||
195 | /* os_error()-- Operating system error. We get a message from the | |
196 | * operating system, show it and leave. Some operating system errors | |
197 | * are caught and processed by the library. If not, we come here. */ | |
198 | ||
199 | void | |
200 | os_error (const char *message) | |
201 | { | |
6de9cd9a | 202 | recursion_check (); |
6de9cd9a | 203 | st_printf ("Operating system error: %s\n%s\n", get_oserror (), message); |
6de9cd9a DN |
204 | sys_exit (1); |
205 | } | |
1529b8d9 | 206 | iexport(os_error); |
6de9cd9a DN |
207 | |
208 | ||
209 | /* void runtime_error()-- These are errors associated with an | |
210 | * invalid fortran program. */ | |
211 | ||
212 | void | |
d8163f5c | 213 | runtime_error (const char *message, ...) |
6de9cd9a | 214 | { |
d8163f5c TK |
215 | va_list ap; |
216 | ||
6de9cd9a | 217 | recursion_check (); |
d8163f5c TK |
218 | st_printf ("Fortran runtime error: "); |
219 | va_start (ap, message); | |
220 | st_vprintf (message, ap); | |
221 | va_end (ap); | |
222 | st_printf ("\n"); | |
6de9cd9a DN |
223 | sys_exit (2); |
224 | } | |
7d7b8bfe | 225 | iexport(runtime_error); |
6de9cd9a | 226 | |
cb13c288 JD |
227 | /* void runtime_error_at()-- These are errors associated with a |
228 | * run time error generated by the front end compiler. */ | |
229 | ||
230 | void | |
c8fe94c7 | 231 | runtime_error_at (const char *where, const char *message, ...) |
cb13c288 | 232 | { |
c8fe94c7 FXC |
233 | va_list ap; |
234 | ||
cb13c288 JD |
235 | recursion_check (); |
236 | st_printf ("%s\n", where); | |
c8fe94c7 FXC |
237 | st_printf ("Fortran runtime error: "); |
238 | va_start (ap, message); | |
239 | st_vprintf (message, ap); | |
240 | va_end (ap); | |
241 | st_printf ("\n"); | |
cb13c288 JD |
242 | sys_exit (2); |
243 | } | |
244 | iexport(runtime_error_at); | |
245 | ||
6de9cd9a | 246 | |
0d52899f TB |
247 | void |
248 | runtime_warning_at (const char *where, const char *message, ...) | |
249 | { | |
250 | va_list ap; | |
251 | ||
252 | st_printf ("%s\n", where); | |
253 | st_printf ("Fortran runtime warning: "); | |
254 | va_start (ap, message); | |
255 | st_vprintf (message, ap); | |
256 | va_end (ap); | |
257 | st_printf ("\n"); | |
258 | } | |
259 | iexport(runtime_warning_at); | |
260 | ||
261 | ||
6de9cd9a DN |
262 | /* void internal_error()-- These are this-can't-happen errors |
263 | * that indicate something deeply wrong. */ | |
264 | ||
265 | void | |
5e805e44 | 266 | internal_error (st_parameter_common *cmp, const char *message) |
6de9cd9a | 267 | { |
6de9cd9a | 268 | recursion_check (); |
5e805e44 | 269 | show_locus (cmp); |
6de9cd9a | 270 | st_printf ("Internal Error: %s\n", message); |
f2ae4b2b FXC |
271 | |
272 | /* This function call is here to get the main.o object file included | |
273 | when linking statically. This works because error.o is supposed to | |
274 | be always linked in (and the function call is in internal_error | |
275 | because hopefully it doesn't happen too often). */ | |
276 | stupid_function_name_for_static_linking(); | |
277 | ||
6de9cd9a DN |
278 | sys_exit (3); |
279 | } | |
280 | ||
281 | ||
282 | /* translate_error()-- Given an integer error code, return a string | |
283 | * describing the error. */ | |
284 | ||
285 | const char * | |
286 | translate_error (int code) | |
287 | { | |
288 | const char *p; | |
289 | ||
290 | switch (code) | |
291 | { | |
d74b97cc | 292 | case LIBERROR_EOR: |
6de9cd9a DN |
293 | p = "End of record"; |
294 | break; | |
295 | ||
d74b97cc | 296 | case LIBERROR_END: |
6de9cd9a DN |
297 | p = "End of file"; |
298 | break; | |
299 | ||
d74b97cc | 300 | case LIBERROR_OK: |
6de9cd9a DN |
301 | p = "Successful return"; |
302 | break; | |
303 | ||
d74b97cc | 304 | case LIBERROR_OS: |
6de9cd9a DN |
305 | p = "Operating system error"; |
306 | break; | |
307 | ||
d74b97cc | 308 | case LIBERROR_BAD_OPTION: |
6de9cd9a DN |
309 | p = "Bad statement option"; |
310 | break; | |
311 | ||
d74b97cc | 312 | case LIBERROR_MISSING_OPTION: |
6de9cd9a DN |
313 | p = "Missing statement option"; |
314 | break; | |
315 | ||
d74b97cc | 316 | case LIBERROR_OPTION_CONFLICT: |
6de9cd9a DN |
317 | p = "Conflicting statement options"; |
318 | break; | |
319 | ||
d74b97cc | 320 | case LIBERROR_ALREADY_OPEN: |
6de9cd9a DN |
321 | p = "File already opened in another unit"; |
322 | break; | |
323 | ||
d74b97cc | 324 | case LIBERROR_BAD_UNIT: |
6de9cd9a DN |
325 | p = "Unattached unit"; |
326 | break; | |
327 | ||
d74b97cc | 328 | case LIBERROR_FORMAT: |
6de9cd9a DN |
329 | p = "FORMAT error"; |
330 | break; | |
331 | ||
d74b97cc | 332 | case LIBERROR_BAD_ACTION: |
6de9cd9a DN |
333 | p = "Incorrect ACTION specified"; |
334 | break; | |
335 | ||
d74b97cc | 336 | case LIBERROR_ENDFILE: |
6de9cd9a DN |
337 | p = "Read past ENDFILE record"; |
338 | break; | |
339 | ||
d74b97cc | 340 | case LIBERROR_BAD_US: |
6de9cd9a DN |
341 | p = "Corrupt unformatted sequential file"; |
342 | break; | |
343 | ||
d74b97cc | 344 | case LIBERROR_READ_VALUE: |
6de9cd9a DN |
345 | p = "Bad value during read"; |
346 | break; | |
347 | ||
d74b97cc | 348 | case LIBERROR_READ_OVERFLOW: |
6de9cd9a DN |
349 | p = "Numeric overflow on read"; |
350 | break; | |
351 | ||
d74b97cc | 352 | case LIBERROR_INTERNAL: |
844234fb JD |
353 | p = "Internal error in run-time library"; |
354 | break; | |
355 | ||
d74b97cc | 356 | case LIBERROR_INTERNAL_UNIT: |
844234fb JD |
357 | p = "Internal unit I/O error"; |
358 | break; | |
359 | ||
d74b97cc | 360 | case LIBERROR_DIRECT_EOR: |
54f9e278 JD |
361 | p = "Write exceeds length of DIRECT access record"; |
362 | break; | |
363 | ||
d74b97cc | 364 | case LIBERROR_SHORT_RECORD: |
07b3bbf2 | 365 | p = "I/O past end of record on unformatted file"; |
8a7f7fb6 TK |
366 | break; |
367 | ||
d74b97cc | 368 | case LIBERROR_CORRUPT_FILE: |
b4c811bd TK |
369 | p = "Unformatted file structure has been corrupted"; |
370 | break; | |
371 | ||
6de9cd9a DN |
372 | default: |
373 | p = "Unknown error code"; | |
374 | break; | |
375 | } | |
376 | ||
377 | return p; | |
378 | } | |
379 | ||
380 | ||
381 | /* generate_error()-- Come here when an error happens. This | |
7aba8abe TK |
382 | * subroutine is called if it is possible to continue on after the error. |
383 | * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or | |
384 | * ERR labels are present, we return, otherwise we terminate the program | |
385 | * after printing a message. The error code is always required but the | |
6de9cd9a DN |
386 | * message parameter can be NULL, in which case a string describing |
387 | * the most recent operating system error is used. */ | |
388 | ||
389 | void | |
5e805e44 | 390 | generate_error (st_parameter_common *cmp, int family, const char *message) |
6de9cd9a | 391 | { |
ceac3d59 TK |
392 | |
393 | /* If there was a previous error, don't mask it with another | |
394 | error message, EOF or EOR condition. */ | |
395 | ||
396 | if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR) | |
397 | return; | |
398 | ||
244fada7 | 399 | /* Set the error status. */ |
5e805e44 | 400 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
d74b97cc | 401 | *cmp->iostat = (family == LIBERROR_OS) ? errno : family; |
6de9cd9a | 402 | |
7aba8abe TK |
403 | if (message == NULL) |
404 | message = | |
d74b97cc | 405 | (family == LIBERROR_OS) ? get_oserror () : translate_error (family); |
7aba8abe | 406 | |
5e805e44 JJ |
407 | if (cmp->flags & IOPARM_HAS_IOMSG) |
408 | cf_strcpy (cmp->iomsg, cmp->iomsg_len, message); | |
7aba8abe | 409 | |
244fada7 | 410 | /* Report status back to the compiler. */ |
5e805e44 | 411 | cmp->flags &= ~IOPARM_LIBRETURN_MASK; |
6de9cd9a DN |
412 | switch (family) |
413 | { | |
d74b97cc | 414 | case LIBERROR_EOR: |
5e805e44 JJ |
415 | cmp->flags |= IOPARM_LIBRETURN_EOR; |
416 | if ((cmp->flags & IOPARM_EOR)) | |
6de9cd9a DN |
417 | return; |
418 | break; | |
419 | ||
d74b97cc | 420 | case LIBERROR_END: |
5e805e44 JJ |
421 | cmp->flags |= IOPARM_LIBRETURN_END; |
422 | if ((cmp->flags & IOPARM_END)) | |
6de9cd9a DN |
423 | return; |
424 | break; | |
425 | ||
426 | default: | |
5e805e44 JJ |
427 | cmp->flags |= IOPARM_LIBRETURN_ERROR; |
428 | if ((cmp->flags & IOPARM_ERR)) | |
244fada7 | 429 | return; |
6de9cd9a DN |
430 | break; |
431 | } | |
432 | ||
244fada7 | 433 | /* Return if the user supplied an iostat variable. */ |
5e805e44 | 434 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
6de9cd9a DN |
435 | return; |
436 | ||
437 | /* Terminate the program */ | |
438 | ||
5e805e44 JJ |
439 | recursion_check (); |
440 | show_locus (cmp); | |
441 | st_printf ("Fortran runtime error: %s\n", message); | |
442 | sys_exit (2); | |
6de9cd9a | 443 | } |
cb13c288 | 444 | iexport(generate_error); |
8b67b708 | 445 | |
fc5f5bb7 JD |
446 | |
447 | /* generate_warning()-- Similar to generate_error but just give a warning. */ | |
448 | ||
449 | void | |
450 | generate_warning (st_parameter_common *cmp, const char *message) | |
451 | { | |
452 | if (message == NULL) | |
453 | message = " "; | |
454 | ||
455 | show_locus (cmp); | |
456 | st_printf ("Fortran runtime warning: %s\n", message); | |
457 | } | |
458 | ||
459 | ||
8f0d39a8 FXC |
460 | /* Whether, for a feature included in a given standard set (GFC_STD_*), |
461 | we should issue an error or a warning, or be quiet. */ | |
462 | ||
463 | notification | |
464 | notification_std (int std) | |
465 | { | |
466 | int warning; | |
467 | ||
468 | if (!compile_options.pedantic) | |
b2ef02df | 469 | return NOTIFICATION_SILENT; |
8f0d39a8 FXC |
470 | |
471 | warning = compile_options.warn_std & std; | |
472 | if ((compile_options.allow_std & std) != 0 && !warning) | |
b2ef02df | 473 | return NOTIFICATION_SILENT; |
8f0d39a8 | 474 | |
b2ef02df | 475 | return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR; |
8f0d39a8 FXC |
476 | } |
477 | ||
478 | ||
8b67b708 FXC |
479 | /* Possibly issue a warning/error about use of a nonstandard (or deleted) |
480 | feature. An error/warning will be issued if the currently selected | |
481 | standard does not contain the requested bits. */ | |
482 | ||
483 | try | |
2e444427 | 484 | notify_std (st_parameter_common *cmp, int std, const char * message) |
8b67b708 FXC |
485 | { |
486 | int warning; | |
487 | ||
5f8f5313 FXC |
488 | if (!compile_options.pedantic) |
489 | return SUCCESS; | |
490 | ||
8b67b708 FXC |
491 | warning = compile_options.warn_std & std; |
492 | if ((compile_options.allow_std & std) != 0 && !warning) | |
493 | return SUCCESS; | |
494 | ||
8b67b708 FXC |
495 | if (!warning) |
496 | { | |
2e444427 JD |
497 | recursion_check (); |
498 | show_locus (cmp); | |
8b67b708 FXC |
499 | st_printf ("Fortran runtime error: %s\n", message); |
500 | sys_exit (2); | |
501 | } | |
502 | else | |
2e444427 JD |
503 | { |
504 | show_locus (cmp); | |
505 | st_printf ("Fortran runtime warning: %s\n", message); | |
506 | } | |
8b67b708 FXC |
507 | return FAILURE; |
508 | } |