libgfortran/runtime/error.c

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