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