]>
Commit | Line | Data |
---|---|---|
723553bd | 1 | /* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009, 2010, 2011 |
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> |
eedeea04 | 31 | #include <signal.h> |
eedeea04 FXC |
32 | |
33 | #ifdef HAVE_UNISTD_H | |
34 | #include <unistd.h> | |
35 | #endif | |
36 | ||
eedeea04 | 37 | #include <stdlib.h> |
eedeea04 | 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 | |
eedeea04 FXC |
50 | #ifdef __MINGW32__ |
51 | #define HAVE_GETPID 1 | |
52 | #include <process.h> | |
53 | #endif | |
54 | ||
55 | ||
de8bd142 JB |
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 | */ | |
eedeea04 | 82 | |
6de9cd9a DN |
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 | |
6de9cd9a DN |
93 | * |
94 | * Other error returns are reserved for the STOP statement with a numeric code. | |
95 | */ | |
96 | ||
1028b2bd JB |
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)); | |
de8bd142 | 135 | sys_abort (); |
1028b2bd JB |
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 | ||
de8bd142 JB |
158 | /* sys_abort()-- Terminate the program showing backtrace and dumping |
159 | core. */ | |
160 | ||
161 | void | |
f6da75ed | 162 | sys_abort (void) |
de8bd142 JB |
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 (); | |
de8bd142 | 170 | signal (SIGABRT, SIG_DFL); |
de8bd142 JB |
171 | } |
172 | ||
173 | abort(); | |
174 | } | |
175 | ||
176 | ||
f9bfed22 | 177 | /* gfc_xtoa()-- Integer to hexadecimal conversion. */ |
6de9cd9a | 178 | |
1449b8cb | 179 | const char * |
f9bfed22 | 180 | gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) |
6de9cd9a DN |
181 | { |
182 | int digit; | |
183 | char *p; | |
184 | ||
1449b8cb JJ |
185 | assert (len >= GFC_XTOA_BUF_SIZE); |
186 | ||
6de9cd9a | 187 | if (n == 0) |
1449b8cb | 188 | return "0"; |
6de9cd9a | 189 | |
1449b8cb JJ |
190 | p = buffer + GFC_XTOA_BUF_SIZE - 1; |
191 | *p = '\0'; | |
6de9cd9a DN |
192 | |
193 | while (n != 0) | |
194 | { | |
195 | digit = n & 0xF; | |
196 | if (digit > 9) | |
197 | digit += 'A' - '0' - 10; | |
198 | ||
1449b8cb | 199 | *--p = '0' + digit; |
6de9cd9a DN |
200 | n >>= 4; |
201 | } | |
202 | ||
1449b8cb | 203 | return p; |
6de9cd9a DN |
204 | } |
205 | ||
723553bd JB |
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 | |
6ef98271 FXC |
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)); | |
723553bd JB |
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 | ||
6de9cd9a DN |
230 | /* show_locus()-- Print a line number and filename describing where |
231 | * something went wrong */ | |
232 | ||
233 | void | |
5e805e44 | 234 | show_locus (st_parameter_common *cmp) |
6de9cd9a | 235 | { |
1028b2bd | 236 | char *filename; |
87557722 | 237 | |
5e805e44 | 238 | if (!options.locus || cmp == NULL || cmp->filename == NULL) |
6de9cd9a | 239 | return; |
87557722 JD |
240 | |
241 | if (cmp->unit > 0) | |
242 | { | |
243 | filename = filename_from_unit (cmp->unit); | |
1028b2bd | 244 | |
87557722 JD |
245 | if (filename != NULL) |
246 | { | |
247 | st_printf ("At line %d of file %s (unit = %d, file = '%s')\n", | |
4e2eb53c | 248 | (int) cmp->line, cmp->filename, (int) cmp->unit, filename); |
bb408e87 | 249 | free (filename); |
87557722 | 250 | } |
c26cc9a6 JD |
251 | else |
252 | { | |
253 | st_printf ("At line %d of file %s (unit = %d)\n", | |
4e2eb53c | 254 | (int) cmp->line, cmp->filename, (int) cmp->unit); |
c26cc9a6 | 255 | } |
87557722 JD |
256 | return; |
257 | } | |
6de9cd9a | 258 | |
6c0e51c4 | 259 | st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename); |
6de9cd9a DN |
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 | ||
f21edfd6 | 274 | /* Don't even try to print something at this point */ |
6de9cd9a | 275 | if (magic == MAGIC) |
de8bd142 | 276 | sys_abort (); |
6de9cd9a DN |
277 | |
278 | magic = MAGIC; | |
279 | } | |
280 | ||
281 | ||
723553bd JB |
282 | #define STRERR_MAXSZ 256 |
283 | ||
6de9cd9a DN |
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 | { | |
723553bd | 291 | char errmsg[STRERR_MAXSZ]; |
6de9cd9a | 292 | recursion_check (); |
1028b2bd JB |
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"); | |
de8bd142 | 298 | exit (1); |
6de9cd9a | 299 | } |
1529b8d9 | 300 | iexport(os_error); |
6de9cd9a DN |
301 | |
302 | ||
303 | /* void runtime_error()-- These are errors associated with an | |
304 | * invalid fortran program. */ | |
305 | ||
306 | void | |
d8163f5c | 307 | runtime_error (const char *message, ...) |
6de9cd9a | 308 | { |
d8163f5c TK |
309 | va_list ap; |
310 | ||
6de9cd9a | 311 | recursion_check (); |
1028b2bd | 312 | estr_write ("Fortran runtime error: "); |
d8163f5c TK |
313 | va_start (ap, message); |
314 | st_vprintf (message, ap); | |
315 | va_end (ap); | |
1028b2bd | 316 | estr_write ("\n"); |
de8bd142 | 317 | exit (2); |
6de9cd9a | 318 | } |
7d7b8bfe | 319 | iexport(runtime_error); |
6de9cd9a | 320 | |
cb13c288 JD |
321 | /* void runtime_error_at()-- These are errors associated with a |
322 | * run time error generated by the front end compiler. */ | |
323 | ||
324 | void | |
c8fe94c7 | 325 | runtime_error_at (const char *where, const char *message, ...) |
cb13c288 | 326 | { |
c8fe94c7 FXC |
327 | va_list ap; |
328 | ||
cb13c288 | 329 | recursion_check (); |
1028b2bd JB |
330 | estr_write (where); |
331 | estr_write ("\nFortran runtime error: "); | |
c8fe94c7 FXC |
332 | va_start (ap, message); |
333 | st_vprintf (message, ap); | |
334 | va_end (ap); | |
1028b2bd | 335 | estr_write ("\n"); |
de8bd142 | 336 | exit (2); |
cb13c288 JD |
337 | } |
338 | iexport(runtime_error_at); | |
339 | ||
6de9cd9a | 340 | |
0d52899f TB |
341 | void |
342 | runtime_warning_at (const char *where, const char *message, ...) | |
343 | { | |
344 | va_list ap; | |
345 | ||
1028b2bd JB |
346 | estr_write (where); |
347 | estr_write ("\nFortran runtime warning: "); | |
0d52899f TB |
348 | va_start (ap, message); |
349 | st_vprintf (message, ap); | |
350 | va_end (ap); | |
1028b2bd | 351 | estr_write ("\n"); |
0d52899f TB |
352 | } |
353 | iexport(runtime_warning_at); | |
354 | ||
355 | ||
6de9cd9a DN |
356 | /* void internal_error()-- These are this-can't-happen errors |
357 | * that indicate something deeply wrong. */ | |
358 | ||
359 | void | |
5e805e44 | 360 | internal_error (st_parameter_common *cmp, const char *message) |
6de9cd9a | 361 | { |
6de9cd9a | 362 | recursion_check (); |
5e805e44 | 363 | show_locus (cmp); |
1028b2bd JB |
364 | estr_write ("Internal Error: "); |
365 | estr_write (message); | |
366 | estr_write ("\n"); | |
f2ae4b2b FXC |
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 | ||
de8bd142 | 374 | exit (3); |
6de9cd9a DN |
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 | { | |
d74b97cc | 388 | case LIBERROR_EOR: |
6de9cd9a DN |
389 | p = "End of record"; |
390 | break; | |
391 | ||
d74b97cc | 392 | case LIBERROR_END: |
6de9cd9a DN |
393 | p = "End of file"; |
394 | break; | |
395 | ||
d74b97cc | 396 | case LIBERROR_OK: |
6de9cd9a DN |
397 | p = "Successful return"; |
398 | break; | |
399 | ||
d74b97cc | 400 | case LIBERROR_OS: |
6de9cd9a DN |
401 | p = "Operating system error"; |
402 | break; | |
403 | ||
d74b97cc | 404 | case LIBERROR_BAD_OPTION: |
6de9cd9a DN |
405 | p = "Bad statement option"; |
406 | break; | |
407 | ||
d74b97cc | 408 | case LIBERROR_MISSING_OPTION: |
6de9cd9a DN |
409 | p = "Missing statement option"; |
410 | break; | |
411 | ||
d74b97cc | 412 | case LIBERROR_OPTION_CONFLICT: |
6de9cd9a DN |
413 | p = "Conflicting statement options"; |
414 | break; | |
415 | ||
d74b97cc | 416 | case LIBERROR_ALREADY_OPEN: |
6de9cd9a DN |
417 | p = "File already opened in another unit"; |
418 | break; | |
419 | ||
d74b97cc | 420 | case LIBERROR_BAD_UNIT: |
6de9cd9a DN |
421 | p = "Unattached unit"; |
422 | break; | |
423 | ||
d74b97cc | 424 | case LIBERROR_FORMAT: |
6de9cd9a DN |
425 | p = "FORMAT error"; |
426 | break; | |
427 | ||
d74b97cc | 428 | case LIBERROR_BAD_ACTION: |
6de9cd9a DN |
429 | p = "Incorrect ACTION specified"; |
430 | break; | |
431 | ||
d74b97cc | 432 | case LIBERROR_ENDFILE: |
6de9cd9a DN |
433 | p = "Read past ENDFILE record"; |
434 | break; | |
435 | ||
d74b97cc | 436 | case LIBERROR_BAD_US: |
6de9cd9a DN |
437 | p = "Corrupt unformatted sequential file"; |
438 | break; | |
439 | ||
d74b97cc | 440 | case LIBERROR_READ_VALUE: |
6de9cd9a DN |
441 | p = "Bad value during read"; |
442 | break; | |
443 | ||
d74b97cc | 444 | case LIBERROR_READ_OVERFLOW: |
6de9cd9a DN |
445 | p = "Numeric overflow on read"; |
446 | break; | |
447 | ||
d74b97cc | 448 | case LIBERROR_INTERNAL: |
844234fb JD |
449 | p = "Internal error in run-time library"; |
450 | break; | |
451 | ||
d74b97cc | 452 | case LIBERROR_INTERNAL_UNIT: |
844234fb JD |
453 | p = "Internal unit I/O error"; |
454 | break; | |
455 | ||
d74b97cc | 456 | case LIBERROR_DIRECT_EOR: |
54f9e278 JD |
457 | p = "Write exceeds length of DIRECT access record"; |
458 | break; | |
459 | ||
d74b97cc | 460 | case LIBERROR_SHORT_RECORD: |
07b3bbf2 | 461 | p = "I/O past end of record on unformatted file"; |
8a7f7fb6 TK |
462 | break; |
463 | ||
d74b97cc | 464 | case LIBERROR_CORRUPT_FILE: |
b4c811bd TK |
465 | p = "Unformatted file structure has been corrupted"; |
466 | break; | |
467 | ||
6de9cd9a DN |
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 | |
7aba8abe TK |
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 | |
6de9cd9a DN |
482 | * message parameter can be NULL, in which case a string describing |
483 | * the most recent operating system error is used. */ | |
484 | ||
485 | void | |
5e805e44 | 486 | generate_error (st_parameter_common *cmp, int family, const char *message) |
6de9cd9a | 487 | { |
723553bd | 488 | char errmsg[STRERR_MAXSZ]; |
ceac3d59 TK |
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 | ||
244fada7 | 496 | /* Set the error status. */ |
5e805e44 | 497 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
d74b97cc | 498 | *cmp->iostat = (family == LIBERROR_OS) ? errno : family; |
6de9cd9a | 499 | |
7aba8abe TK |
500 | if (message == NULL) |
501 | message = | |
723553bd JB |
502 | (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) : |
503 | translate_error (family); | |
7aba8abe | 504 | |
5e805e44 JJ |
505 | if (cmp->flags & IOPARM_HAS_IOMSG) |
506 | cf_strcpy (cmp->iomsg, cmp->iomsg_len, message); | |
7aba8abe | 507 | |
244fada7 | 508 | /* Report status back to the compiler. */ |
5e805e44 | 509 | cmp->flags &= ~IOPARM_LIBRETURN_MASK; |
6de9cd9a DN |
510 | switch (family) |
511 | { | |
d74b97cc | 512 | case LIBERROR_EOR: |
5e805e44 JJ |
513 | cmp->flags |= IOPARM_LIBRETURN_EOR; |
514 | if ((cmp->flags & IOPARM_EOR)) | |
6de9cd9a DN |
515 | return; |
516 | break; | |
517 | ||
d74b97cc | 518 | case LIBERROR_END: |
5e805e44 JJ |
519 | cmp->flags |= IOPARM_LIBRETURN_END; |
520 | if ((cmp->flags & IOPARM_END)) | |
6de9cd9a DN |
521 | return; |
522 | break; | |
523 | ||
524 | default: | |
5e805e44 JJ |
525 | cmp->flags |= IOPARM_LIBRETURN_ERROR; |
526 | if ((cmp->flags & IOPARM_ERR)) | |
244fada7 | 527 | return; |
6de9cd9a DN |
528 | break; |
529 | } | |
530 | ||
244fada7 | 531 | /* Return if the user supplied an iostat variable. */ |
5e805e44 | 532 | if ((cmp->flags & IOPARM_HAS_IOSTAT)) |
6de9cd9a DN |
533 | return; |
534 | ||
535 | /* Terminate the program */ | |
536 | ||
5e805e44 JJ |
537 | recursion_check (); |
538 | show_locus (cmp); | |
1028b2bd JB |
539 | estr_write ("Fortran runtime error: "); |
540 | estr_write (message); | |
541 | estr_write ("\n"); | |
de8bd142 | 542 | exit (2); |
6de9cd9a | 543 | } |
cb13c288 | 544 | iexport(generate_error); |
8b67b708 | 545 | |
fc5f5bb7 JD |
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); | |
1028b2bd JB |
556 | estr_write ("Fortran runtime warning: "); |
557 | estr_write (message); | |
558 | estr_write ("\n"); | |
fc5f5bb7 JD |
559 | } |
560 | ||
561 | ||
8f0d39a8 FXC |
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) | |
b2ef02df | 571 | return NOTIFICATION_SILENT; |
8f0d39a8 FXC |
572 | |
573 | warning = compile_options.warn_std & std; | |
574 | if ((compile_options.allow_std & std) != 0 && !warning) | |
b2ef02df | 575 | return NOTIFICATION_SILENT; |
8f0d39a8 | 576 | |
b2ef02df | 577 | return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR; |
8f0d39a8 FXC |
578 | } |
579 | ||
580 | ||
8b67b708 FXC |
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 | |
2e444427 | 586 | notify_std (st_parameter_common *cmp, int std, const char * message) |
8b67b708 FXC |
587 | { |
588 | int warning; | |
589 | ||
5f8f5313 FXC |
590 | if (!compile_options.pedantic) |
591 | return SUCCESS; | |
592 | ||
8b67b708 FXC |
593 | warning = compile_options.warn_std & std; |
594 | if ((compile_options.allow_std & std) != 0 && !warning) | |
595 | return SUCCESS; | |
596 | ||
8b67b708 FXC |
597 | if (!warning) |
598 | { | |
2e444427 JD |
599 | recursion_check (); |
600 | show_locus (cmp); | |
1028b2bd JB |
601 | estr_write ("Fortran runtime error: "); |
602 | estr_write (message); | |
603 | estr_write ("\n"); | |
de8bd142 | 604 | exit (2); |
8b67b708 FXC |
605 | } |
606 | else | |
2e444427 JD |
607 | { |
608 | show_locus (cmp); | |
1028b2bd JB |
609 | estr_write ("Fortran runtime warning: "); |
610 | estr_write (message); | |
611 | estr_write ("\n"); | |
2e444427 | 612 | } |
8b67b708 FXC |
613 | return FAILURE; |
614 | } |