1 /* Copyright (C) 2002-2023 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3
4 This file is part of the GNU Fortran runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 3, or (at your option)
9 any later version.
10
11 Libgfortran is distributed in the hope that it will be useful,
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
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/>. */
24
25
26 #include "libgfortran.h"
27 #include "io.h"
28 #include "async.h"
29
30 #include <assert.h>
31 #include <string.h>
32 #include <errno.h>
33 #include <signal.h>
34
35 #ifdef HAVE_UNISTD_H
36 #include <unistd.h>
37 #endif
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 #include <locale.h>
51
52 #ifdef HAVE_XLOCALE_H
53 #include <xlocale.h>
54 #endif
55
56
57 #ifdef __MINGW32__
58 #define HAVE_GETPID 1
59 #include <process.h>
60 #endif
61
62
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
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.
89
90 */
91
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
102 *
103 * Other error returns are reserved for the STOP statement with a numeric code.
104 */
105
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
117 /* Write a vector of strings to standard error. This function is
118 async-signal-safe. */
119
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 }
137
138
139 #ifndef HAVE_VSNPRINTF
140 static int
141 gf_vsnprintf (char *str, size_t size, const char *format, va_list ap)
142 {
143 int written;
144
145 written = vsprintf(buffer, format, ap);
146
147 if (written >= size - 1)
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. */
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));
155 sys_abort ();
156 #undef ERROR_MESSAGE
157
158 }
159 return written;
160 }
161
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
171
172 int
173 st_printf (const char * format, ...)
174 {
175 char buffer[ST_ERRBUF_SIZE];
176 int written;
177 va_list ap;
178 va_start (ap, format);
179 written = vsnprintf (buffer, ST_ERRBUF_SIZE, format, ap);
180 va_end (ap);
181 written = write (STDERR_FILENO, buffer, written);
182 return written;
183 }
184
185
186 /* sys_abort()-- Terminate the program showing backtrace and dumping
187 core. */
188
189 void
190 sys_abort (void)
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 {
197 estr_write ("\nProgram aborted. Backtrace:\n");
198 show_backtrace (false);
199 signal (SIGABRT, SIG_DFL);
200 }
201
202 abort();
203 }
204
205
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 /* Hopefully thread-safe wrapper for a strerror() style function. */
223
224 char *
225 gf_strerror (int errnum,
226 char * buf __attribute__((unused)),
227 size_t buflen __attribute__((unused)))
228 {
229 #ifdef HAVE_STRERROR_L
230 locale_t myloc = newlocale (LC_CTYPE_MASK | LC_MESSAGES_MASK, "",
231 (locale_t) 0);
232 char *p;
233 if (myloc)
234 {
235 p = strerror_l (errnum, myloc);
236 freelocale (myloc);
237 }
238 else
239 /* newlocale might fail e.g. due to running out of memory, fall
240 back to the simpler strerror. */
241 p = strerror (errnum);
242 return p;
243 #elif defined(HAVE_STRERROR_R)
244 #ifdef HAVE_POSIX_2008_LOCALE
245 /* Some targets (Darwin at least) have the POSIX 2008 extended
246 locale functions, but not strerror_l. So reset the per-thread
247 locale here. */
248 uselocale (LC_GLOBAL_LOCALE);
249 #endif
250 /* POSIX returns an "int", GNU a "char*". */
251 return
252 __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0))
253 == 5,
254 /* GNU strerror_r() */
255 strerror_r (errnum, buf, buflen),
256 /* POSIX strerror_r () */
257 (strerror_r (errnum, buf, buflen), buf));
258 #elif defined(HAVE_STRERROR_R_2ARGS)
259 strerror_r (errnum, buf);
260 return buf;
261 #else
262 /* strerror () is not necessarily thread-safe, but should at least
263 be available everywhere. */
264 return strerror (errnum);
265 #endif
266 }
267
268
269 /* show_locus()-- Print a line number and filename describing where
270 * something went wrong */
271
272 void
273 show_locus (st_parameter_common *cmp)
274 {
275 char *filename;
276
277 if (!options.locus || cmp == NULL || cmp->filename == NULL)
278 return;
279
280 if (cmp->unit > 0)
281 {
282 filename = filename_from_unit (cmp->unit);
283
284 if (filename != NULL)
285 {
286 st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
287 (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
288 free (filename);
289 }
290 else
291 {
292 st_printf ("At line %d of file %s (unit = %d)\n",
293 (int) cmp->line, cmp->filename, (int) cmp->unit);
294 }
295 return;
296 }
297
298 st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
299 }
300
301
302 /* recursion_check()-- It's possible for additional errors to occur
303 * during fatal error processing. We detect this condition here and
304 * abort immediately. */
305
306 static __gthread_key_t recursion_key;
307
308 static void
309 recursion_check (void)
310 {
311 if (__gthread_active_p ())
312 {
313 bool* p = __gthread_getspecific (recursion_key);
314 if (!p)
315 {
316 p = xcalloc (1, sizeof (bool));
317 __gthread_setspecific (recursion_key, p);
318 }
319 if (*p)
320 sys_abort ();
321 *p = true;
322 }
323 else
324 {
325 static bool recur;
326 if (recur)
327 sys_abort ();
328 recur = true;
329 }
330 }
331
332 #ifdef __GTHREADS
333 static void __attribute__((constructor))
334 constructor_recursion_check (void)
335 {
336 if (__gthread_active_p ())
337 __gthread_key_create (&recursion_key, &free);
338 }
339
340 static void __attribute__((destructor))
341 destructor_recursion_check (void)
342 {
343 if (__gthread_active_p ())
344 __gthread_key_delete (recursion_key);
345 }
346 #endif
347
348
349
350 #define STRERR_MAXSZ 256
351
352 /* os_error()-- Operating system error. We get a message from the
353 * operating system, show it and leave. Some operating system errors
354 * are caught and processed by the library. If not, we come here. */
355
356 void
357 os_error (const char *message)
358 {
359 char errmsg[STRERR_MAXSZ];
360 struct iovec iov[5];
361 recursion_check ();
362 iov[0].iov_base = (char*) "Operating system error: ";
363 iov[0].iov_len = strlen (iov[0].iov_base);
364 iov[1].iov_base = gf_strerror (errno, errmsg, STRERR_MAXSZ);
365 iov[1].iov_len = strlen (iov[1].iov_base);
366 iov[2].iov_base = (char*) "\n";
367 iov[2].iov_len = 1;
368 iov[3].iov_base = (char*) message;
369 iov[3].iov_len = strlen (message);
370 iov[4].iov_base = (char*) "\n";
371 iov[4].iov_len = 1;
372 estr_writev (iov, 5);
373 exit_error (1);
374 }
375 iexport(os_error); /* TODO, DEPRECATED, ABI: Should not be exported
376 anymore when bumping so version. */
377
378
379 /* Improved version of os_error with a printf style format string and
380 a locus. */
381
382 void
383 os_error_at (const char *where, const char *message, ...)
384 {
385 char errmsg[STRERR_MAXSZ];
386 char buffer[STRERR_MAXSZ];
387 struct iovec iov[6];
388 va_list ap;
389 recursion_check ();
390 int written;
391
392 iov[0].iov_base = (char*) where;
393 iov[0].iov_len = strlen (where);
394
395 iov[1].iov_base = (char*) ": ";
396 iov[1].iov_len = strlen (iov[1].iov_base);
397
398 va_start (ap, message);
399 written = vsnprintf (buffer, STRERR_MAXSZ, message, ap);
400 va_end (ap);
401 iov[2].iov_base = buffer;
402 if (written >= 0)
403 iov[2].iov_len = written;
404 else
405 iov[2].iov_len = 0;
406
407 iov[3].iov_base = (char*) ": ";
408 iov[3].iov_len = strlen (iov[3].iov_base);
409
410 iov[4].iov_base = gf_strerror (errno, errmsg, STRERR_MAXSZ);
411 iov[4].iov_len = strlen (iov[4].iov_base);
412
413 iov[5].iov_base = (char*) "\n";
414 iov[5].iov_len = 1;
415
416 estr_writev (iov, 6);
417 exit_error (1);
418 }
419 iexport(os_error_at);
420
421
422 /* void runtime_error()-- These are errors associated with an
423 * invalid fortran program. */
424
425 void
426 runtime_error (const char *message, ...)
427 {
428 char buffer[ST_ERRBUF_SIZE];
429 struct iovec iov[3];
430 va_list ap;
431 int written;
432
433 recursion_check ();
434 iov[0].iov_base = (char*) "Fortran runtime error: ";
435 iov[0].iov_len = strlen (iov[0].iov_base);
436 va_start (ap, message);
437 written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap);
438 va_end (ap);
439 if (written >= 0)
440 {
441 iov[1].iov_base = buffer;
442 iov[1].iov_len = written;
443 iov[2].iov_base = (char*) "\n";
444 iov[2].iov_len = 1;
445 estr_writev (iov, 3);
446 }
447 exit_error (2);
448 }
449 iexport(runtime_error);
450
451 /* void runtime_error_at()-- These are errors associated with a
452 * run time error generated by the front end compiler. */
453
454 void
455 runtime_error_at (const char *where, const char *message, ...)
456 {
457 char buffer[ST_ERRBUF_SIZE];
458 va_list ap;
459 struct iovec iov[4];
460 int written;
461
462 recursion_check ();
463 iov[0].iov_base = (char*) where;
464 iov[0].iov_len = strlen (where);
465 iov[1].iov_base = (char*) "\nFortran runtime error: ";
466 iov[1].iov_len = strlen (iov[1].iov_base);
467 va_start (ap, message);
468 written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap);
469 va_end (ap);
470 if (written >= 0)
471 {
472 iov[2].iov_base = buffer;
473 iov[2].iov_len = written;
474 iov[3].iov_base = (char*) "\n";
475 iov[3].iov_len = 1;
476 estr_writev (iov, 4);
477 }
478 exit_error (2);
479 }
480 iexport(runtime_error_at);
481
482
483 void
484 runtime_warning_at (const char *where, const char *message, ...)
485 {
486 char buffer[ST_ERRBUF_SIZE];
487 va_list ap;
488 struct iovec iov[4];
489 int written;
490
491 iov[0].iov_base = (char*) where;
492 iov[0].iov_len = strlen (where);
493 iov[1].iov_base = (char*) "\nFortran runtime warning: ";
494 iov[1].iov_len = strlen (iov[1].iov_base);
495 va_start (ap, message);
496 written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap);
497 va_end (ap);
498 if (written >= 0)
499 {
500 iov[2].iov_base = buffer;
501 iov[2].iov_len = written;
502 iov[3].iov_base = (char*) "\n";
503 iov[3].iov_len = 1;
504 estr_writev (iov, 4);
505 }
506 }
507 iexport(runtime_warning_at);
508
509
510 /* void internal_error()-- These are this-can't-happen errors
511 * that indicate something deeply wrong. */
512
513 void
514 internal_error (st_parameter_common *cmp, const char *message)
515 {
516 struct iovec iov[3];
517
518 recursion_check ();
519 show_locus (cmp);
520 iov[0].iov_base = (char*) "Internal Error: ";
521 iov[0].iov_len = strlen (iov[0].iov_base);
522 iov[1].iov_base = (char*) message;
523 iov[1].iov_len = strlen (message);
524 iov[2].iov_base = (char*) "\n";
525 iov[2].iov_len = 1;
526 estr_writev (iov, 3);
527
528 /* This function call is here to get the main.o object file included
529 when linking statically. This works because error.o is supposed to
530 be always linked in (and the function call is in internal_error
531 because hopefully it doesn't happen too often). */
532 stupid_function_name_for_static_linking();
533
534 exit_error (3);
535 }
536
537
538 /* translate_error()-- Given an integer error code, return a string
539 * describing the error. */
540
541 const char *
542 translate_error (int code)
543 {
544 const char *p;
545
546 switch (code)
547 {
548 case LIBERROR_EOR:
549 p = "End of record";
550 break;
551
552 case LIBERROR_END:
553 p = "End of file";
554 break;
555
556 case LIBERROR_OK:
557 p = "Successful return";
558 break;
559
560 case LIBERROR_OS:
561 p = "Operating system error";
562 break;
563
564 case LIBERROR_BAD_OPTION:
565 p = "Bad statement option";
566 break;
567
568 case LIBERROR_MISSING_OPTION:
569 p = "Missing statement option";
570 break;
571
572 case LIBERROR_OPTION_CONFLICT:
573 p = "Conflicting statement options";
574 break;
575
576 case LIBERROR_ALREADY_OPEN:
577 p = "File already opened in another unit";
578 break;
579
580 case LIBERROR_BAD_UNIT:
581 p = "Unattached unit";
582 break;
583
584 case LIBERROR_FORMAT:
585 p = "FORMAT error";
586 break;
587
588 case LIBERROR_BAD_ACTION:
589 p = "Incorrect ACTION specified";
590 break;
591
592 case LIBERROR_ENDFILE:
593 p = "Read past ENDFILE record";
594 break;
595
596 case LIBERROR_BAD_US:
597 p = "Corrupt unformatted sequential file";
598 break;
599
600 case LIBERROR_READ_VALUE:
601 p = "Bad value during read";
602 break;
603
604 case LIBERROR_READ_OVERFLOW:
605 p = "Numeric overflow on read";
606 break;
607
608 case LIBERROR_INTERNAL:
609 p = "Internal error in run-time library";
610 break;
611
612 case LIBERROR_INTERNAL_UNIT:
613 p = "Internal unit I/O error";
614 break;
615
616 case LIBERROR_DIRECT_EOR:
617 p = "Write exceeds length of DIRECT access record";
618 break;
619
620 case LIBERROR_SHORT_RECORD:
621 p = "I/O past end of record on unformatted file";
622 break;
623
624 case LIBERROR_CORRUPT_FILE:
625 p = "Unformatted file structure has been corrupted";
626 break;
627
628 case LIBERROR_INQUIRE_INTERNAL_UNIT:
629 p = "Inquire statement identifies an internal file";
630 break;
631
632 case LIBERROR_BAD_WAIT_ID:
633 p = "Bad ID in WAIT statement";
634 break;
635
636 default:
637 p = "Unknown error code";
638 break;
639 }
640
641 return p;
642 }
643
644
645 /* Worker function for generate_error and generate_error_async. Return true
646 if a straight return is to be done, zero if the program should abort. */
647
648 bool
649 generate_error_common (st_parameter_common *cmp, int family, const char *message)
650 {
651 char errmsg[STRERR_MAXSZ];
652
653 #if ASYNC_IO
654 gfc_unit *u;
655
656 NOTE ("Entering generate_error_common");
657
658 u = thread_unit;
659 if (u && u->au)
660 {
661 if (u->au->error.has_error)
662 return true;
663
664 if (__gthread_equal (u->au->thread, __gthread_self ()))
665 {
666 u->au->error.has_error = 1;
667 u->au->error.cmp = cmp;
668 u->au->error.family = family;
669 u->au->error.message = message;
670 return true;
671 }
672 }
673 #endif
674
675 /* If there was a previous error, don't mask it with another
676 error message, EOF or EOR condition. */
677
678 if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
679 return true;
680
681 /* Set the error status. */
682 if ((cmp->flags & IOPARM_HAS_IOSTAT))
683 *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
684
685 if (message == NULL)
686 message =
687 (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
688 translate_error (family);
689
690 if (cmp->flags & IOPARM_HAS_IOMSG)
691 cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
692
693 /* Report status back to the compiler. */
694 cmp->flags &= ~IOPARM_LIBRETURN_MASK;
695 switch (family)
696 {
697 case LIBERROR_EOR:
698 cmp->flags |= IOPARM_LIBRETURN_EOR; NOTE("EOR");
699 if ((cmp->flags & IOPARM_EOR))
700 return true;
701 break;
702
703 case LIBERROR_END:
704 cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END");
705 if ((cmp->flags & IOPARM_END))
706 return true;
707 break;
708
709 default:
710 cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR");
711 if ((cmp->flags & IOPARM_ERR))
712 return true;
713 break;
714 }
715
716 /* Return if the user supplied an iostat variable. */
717 if ((cmp->flags & IOPARM_HAS_IOSTAT))
718 return true;
719
720 /* Return code, caller is responsible for terminating
721 the program if necessary. */
722
723 recursion_check ();
724 show_locus (cmp);
725 struct iovec iov[3];
726 iov[0].iov_base = (char*) "Fortran runtime error: ";
727 iov[0].iov_len = strlen (iov[0].iov_base);
728 iov[1].iov_base = (char*) message;
729 iov[1].iov_len = strlen (message);
730 iov[2].iov_base = (char*) "\n";
731 iov[2].iov_len = 1;
732 estr_writev (iov, 3);
733 return false;
734 }
735
736 /* generate_error()-- Come here when an error happens. This
737 * subroutine is called if it is possible to continue on after the error.
738 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
739 * ERR labels are present, we return, otherwise we terminate the program
740 * after printing a message. The error code is always required but the
741 * message parameter can be NULL, in which case a string describing
742 * the most recent operating system error is used.
743 * If the error is for an asynchronous unit and if the program is currently
744 * executing the asynchronous thread, just mark the error and return. */
745
746 void
747 generate_error (st_parameter_common *cmp, int family, const char *message)
748 {
749 if (generate_error_common (cmp, family, message))
750 return;
751
752 exit_error(2);
753 }
754 iexport(generate_error);
755
756
757 /* generate_warning()-- Similar to generate_error but just give a warning. */
758
759 void
760 generate_warning (st_parameter_common *cmp, const char *message)
761 {
762 if (message == NULL)
763 message = " ";
764
765 show_locus (cmp);
766 struct iovec iov[3];
767 iov[0].iov_base = (char*) "Fortran runtime warning: ";
768 iov[0].iov_len = strlen (iov[0].iov_base);
769 iov[1].iov_base = (char*) message;
770 iov[1].iov_len = strlen (message);
771 iov[2].iov_base = (char*) "\n";
772 iov[2].iov_len = 1;
773 estr_writev (iov, 3);
774 }
775
776
777 /* Whether, for a feature included in a given standard set (GFC_STD_*),
778 we should issue an error or a warning, or be quiet. */
779
780 notification
781 notification_std (int std)
782 {
783 int warning;
784
785 if (!compile_options.pedantic)
786 return NOTIFICATION_SILENT;
787
788 warning = compile_options.warn_std & std;
789 if ((compile_options.allow_std & std) != 0 && !warning)
790 return NOTIFICATION_SILENT;
791
792 return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
793 }
794
795
796 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
797 feature. An error/warning will be issued if the currently selected
798 standard does not contain the requested bits. */
799
800 bool
801 notify_std (st_parameter_common *cmp, int std, const char * message)
802 {
803 int warning;
804 struct iovec iov[3];
805
806 if (!compile_options.pedantic)
807 return true;
808
809 warning = compile_options.warn_std & std;
810 if ((compile_options.allow_std & std) != 0 && !warning)
811 return true;
812
813 if (!warning)
814 {
815 recursion_check ();
816 show_locus (cmp);
817 iov[0].iov_base = (char*) "Fortran runtime error: ";
818 iov[0].iov_len = strlen (iov[0].iov_base);
819 iov[1].iov_base = (char*) message;
820 iov[1].iov_len = strlen (message);
821 iov[2].iov_base = (char*) "\n";
822 iov[2].iov_len = 1;
823 estr_writev (iov, 3);
824 exit_error (2);
825 }
826 else
827 {
828 show_locus (cmp);
829 iov[0].iov_base = (char*) "Fortran runtime warning: ";
830 iov[0].iov_len = strlen (iov[0].iov_base);
831 iov[1].iov_base = (char*) message;
832 iov[1].iov_len = strlen (message);
833 iov[2].iov_base = (char*) "\n";
834 iov[2].iov_len = 1;
835 estr_writev (iov, 3);
836 }
837 return false;
838 }