1/* Copyright (C) 2002-2022 Free Software Foundation, Inc. 2 Contributed by Andy Vaught 3 4This file is part of the GNU Fortran runtime library (libgfortran). 5 6Libgfortran is free software; you can redistribute it and/or modify 7it under the terms of the GNU General Public License as published by 8the Free Software Foundation; either version 3, or (at your option) 9any later version. 10 11Libgfortran is distributed in the hope that it will be useful, 12but WITHOUT ANY WARRANTY; without even the implied warranty of 13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14GNU General Public License for more details. 15 16Under Section 7 of GPL version 3, you are granted additional 17permissions described in the GCC Runtime Library Exception, version 183.1, as published by the Free Software Foundation. 19 20You should have received a copy of the GNU General Public License and 21a copy of the GCC Runtime Library Exception along with this program; 22see 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 110ssize_t 111estr_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 120ssize_t 121estr_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 140static int 141gf_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 172int 173st_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 189void 190sys_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 209void 210exit_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 224char * 225gf_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 272void 273show_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 306static __gthread_key_t recursion_key; 307 308static void 309recursion_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 333static void __attribute__((constructor)) 334constructor_recursion_check (void) 335{ 336 if (__gthread_active_p ()) 337 __gthread_key_create (&recursion_key, &free); 338} 339 340static void __attribute__((destructor)) 341destructor_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 356void 357os_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} 375iexport(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 382void 383os_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} 419iexport(os_error_at); 420 421 422/* void runtime_error()-- These are errors associated with an 423 * invalid fortran program. */ 424 425void 426runtime_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} 449iexport(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 454void 455runtime_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} 480iexport(runtime_error_at); 481 482 483void 484runtime_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} 507iexport(runtime_warning_at); 508 509 510/* void internal_error()-- These are this-can't-happen errors 511 * that indicate something deeply wrong. */ 512 513void 514internal_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 541const char * 542translate_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 648bool 649generate_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 746void 747generate_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} 754iexport(generate_error); 755 756 757/* generate_warning()-- Similar to generate_error but just give a warning. */ 758 759void 760generate_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 780notification 781notification_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 800bool 801notify_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} 839