libgfortran/runtime/error.c

   1 /* Copyright (C) 2002-2018 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_USELOCALE
 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  * exit with code 4 immediately. */
 336
 337 #define MAGIC 0x20DE8101
 338
 339 static void
 340 recursion_check (void)
 341 {
 342   static int magic = 0;
 343
 344   /* Don't even try to print something at this point */
 345   if (magic == MAGIC)
 346     sys_abort ();
 347
 348   magic = MAGIC;
 349 }
 350
 351
 352 #define STRERR_MAXSZ 256
 353
 354 /* os_error()-- Operating system error.  We get a message from the
 355  * operating system, show it and leave.  Some operating system errors
 356  * are caught and processed by the library.  If not, we come here. */
 357
 358 void
 359 os_error (const char *message)
 360 {
 361   char errmsg[STRERR_MAXSZ];
 362   struct iovec iov[5];
 363   recursion_check ();
 364   iov[0].iov_base = (char*) "Operating system error: ";
 365   iov[0].iov_len = strlen (iov[0].iov_base);
 366   iov[1].iov_base = gf_strerror (errno, errmsg, STRERR_MAXSZ);
 367   iov[1].iov_len = strlen (iov[1].iov_base);
 368   iov[2].iov_base = (char*) "\n";
 369   iov[2].iov_len = 1;
 370   iov[3].iov_base = (char*) message;
 371   iov[3].iov_len = strlen (message);
 372   iov[4].iov_base = (char*) "\n";
 373   iov[4].iov_len = 1;
 374   estr_writev (iov, 5);
 375   exit_error (1);
 376 }
 377 iexport(os_error);
 378
 379
 380 /* void runtime_error()-- These are errors associated with an
 381  * invalid fortran program. */
 382
 383 void
 384 runtime_error (const char *message, ...)
 385 {
 386   char buffer[ST_ERRBUF_SIZE];
 387   struct iovec iov[3];
 388   va_list ap;
 389   int written;
 390
 391   recursion_check ();
 392   iov[0].iov_base = (char*) "Fortran runtime error: ";
 393   iov[0].iov_len = strlen (iov[0].iov_base);
 394   va_start (ap, message);
 395   written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap);
 396   va_end (ap);
 397   if (written >= 0)
 398     {
 399       iov[1].iov_base = buffer;
 400       iov[1].iov_len = written;
 401       iov[2].iov_base = (char*) "\n";
 402       iov[2].iov_len = 1;
 403       estr_writev (iov, 3);
 404     }
 405   exit_error (2);
 406 }
 407 iexport(runtime_error);
 408
 409 /* void runtime_error_at()-- These are errors associated with a
 410  * run time error generated by the front end compiler.  */
 411
 412 void
 413 runtime_error_at (const char *where, const char *message, ...)
 414 {
 415   char buffer[ST_ERRBUF_SIZE];
 416   va_list ap;
 417   struct iovec iov[4];
 418   int written;
 419
 420   recursion_check ();
 421   iov[0].iov_base = (char*) where;
 422   iov[0].iov_len = strlen (where);
 423   iov[1].iov_base = (char*) "\nFortran runtime error: ";
 424   iov[1].iov_len = strlen (iov[1].iov_base);
 425   va_start (ap, message);
 426   written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap);
 427   va_end (ap);
 428   if (written >= 0)
 429     {
 430       iov[2].iov_base = buffer;
 431       iov[2].iov_len = written;
 432       iov[3].iov_base = (char*) "\n";
 433       iov[3].iov_len = 1;
 434       estr_writev (iov, 4);
 435     }
 436   exit_error (2);
 437 }
 438 iexport(runtime_error_at);
 439
 440
 441 void
 442 runtime_warning_at (const char *where, const char *message, ...)
 443 {
 444   char buffer[ST_ERRBUF_SIZE];
 445   va_list ap;
 446   struct iovec iov[4];
 447   int written;
 448
 449   iov[0].iov_base = (char*) where;
 450   iov[0].iov_len = strlen (where);
 451   iov[1].iov_base = (char*) "\nFortran runtime warning: ";
 452   iov[1].iov_len = strlen (iov[1].iov_base);
 453   va_start (ap, message);
 454   written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap);
 455   va_end (ap);
 456   if (written >= 0)
 457     {
 458       iov[2].iov_base = buffer;
 459       iov[2].iov_len = written;
 460       iov[3].iov_base = (char*) "\n";
 461       iov[3].iov_len = 1;
 462       estr_writev (iov, 4);
 463     }
 464 }
 465 iexport(runtime_warning_at);
 466
 467
 468 /* void internal_error()-- These are this-can't-happen errors
 469  * that indicate something deeply wrong. */
 470
 471 void
 472 internal_error (st_parameter_common *cmp, const char *message)
 473 {
 474   struct iovec iov[3];
 475
 476   recursion_check ();
 477   show_locus (cmp);
 478   iov[0].iov_base = (char*) "Internal Error: ";
 479   iov[0].iov_len = strlen (iov[0].iov_base);
 480   iov[1].iov_base = (char*) message;
 481   iov[1].iov_len = strlen (message);
 482   iov[2].iov_base = (char*) "\n";
 483   iov[2].iov_len = 1;
 484   estr_writev (iov, 3);
 485
 486   /* This function call is here to get the main.o object file included
 487      when linking statically. This works because error.o is supposed to
 488      be always linked in (and the function call is in internal_error
 489      because hopefully it doesn't happen too often).  */
 490   stupid_function_name_for_static_linking();
 491
 492  exit_error (3);
 493 }
 494
 495
 496 /* translate_error()-- Given an integer error code, return a string
 497  * describing the error. */
 498
 499 const char *
 500 translate_error (int code)
 501 {
 502   const char *p;
 503
 504   switch (code)
 505     {
 506     case LIBERROR_EOR:
 507       p = "End of record";
 508       break;
 509
 510     case LIBERROR_END:
 511       p = "End of file";
 512       break;
 513
 514     case LIBERROR_OK:
 515       p = "Successful return";
 516       break;
 517
 518     case LIBERROR_OS:
 519       p = "Operating system error";
 520       break;
 521
 522     case LIBERROR_BAD_OPTION:
 523       p = "Bad statement option";
 524       break;
 525
 526     case LIBERROR_MISSING_OPTION:
 527       p = "Missing statement option";
 528       break;
 529
 530     case LIBERROR_OPTION_CONFLICT:
 531       p = "Conflicting statement options";
 532       break;
 533
 534     case LIBERROR_ALREADY_OPEN:
 535       p = "File already opened in another unit";
 536       break;
 537
 538     case LIBERROR_BAD_UNIT:
 539       p = "Unattached unit";
 540       break;
 541
 542     case LIBERROR_FORMAT:
 543       p = "FORMAT error";
 544       break;
 545
 546     case LIBERROR_BAD_ACTION:
 547       p = "Incorrect ACTION specified";
 548       break;
 549
 550     case LIBERROR_ENDFILE:
 551       p = "Read past ENDFILE record";
 552       break;
 553
 554     case LIBERROR_BAD_US:
 555       p = "Corrupt unformatted sequential file";
 556       break;
 557
 558     case LIBERROR_READ_VALUE:
 559       p = "Bad value during read";
 560       break;
 561
 562     case LIBERROR_READ_OVERFLOW:
 563       p = "Numeric overflow on read";
 564       break;
 565
 566     case LIBERROR_INTERNAL:
 567       p = "Internal error in run-time library";
 568       break;
 569
 570     case LIBERROR_INTERNAL_UNIT:
 571       p = "Internal unit I/O error";
 572       break;
 573
 574     case LIBERROR_DIRECT_EOR:
 575       p = "Write exceeds length of DIRECT access record";
 576       break;
 577
 578     case LIBERROR_SHORT_RECORD:
 579       p = "I/O past end of record on unformatted file";
 580       break;
 581
 582     case LIBERROR_CORRUPT_FILE:
 583       p = "Unformatted file structure has been corrupted";
 584       break;
 585
 586     case LIBERROR_INQUIRE_INTERNAL_UNIT:
 587       p = "Inquire statement identifies an internal file";
 588       break;
 589
 590     default:
 591       p = "Unknown error code";
 592       break;
 593     }
 594
 595   return p;
 596 }
 597
 598
 599 /* Worker function for generate_error and generate_error_async.  Return true
 600    if a straight return is to be done, zero if the program should abort. */
 601
 602 bool
 603 generate_error_common (st_parameter_common *cmp, int family, const char *message)
 604 {
 605   char errmsg[STRERR_MAXSZ];
 606
 607 #if ASYNC_IO
 608   gfc_unit *u;
 609
 610   NOTE ("Entering generate_error_common");
 611
 612   u = thread_unit;
 613   if (u && u->au)
 614     {
 615       if (u->au->error.has_error)
 616         return true;
 617
 618       if (__gthread_equal (u->au->thread, __gthread_self ()))
 619         {
 620           u->au->error.has_error = 1;
 621           u->au->error.cmp = cmp;
 622           u->au->error.family = family;
 623           u->au->error.message = message;
 624           return true;
 625         }
 626     }
 627 #endif
 628
 629   /* If there was a previous error, don't mask it with another
 630      error message, EOF or EOR condition.  */
 631
 632   if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
 633     return true;
 634
 635   /* Set the error status.  */
 636   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 637     *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
 638
 639   if (message == NULL)
 640     message =
 641       (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
 642       translate_error (family);
 643
 644   if (cmp->flags & IOPARM_HAS_IOMSG)
 645     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 646
 647   /* Report status back to the compiler.  */
 648   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 649   switch (family)
 650     {
 651     case LIBERROR_EOR:
 652       cmp->flags |= IOPARM_LIBRETURN_EOR;  NOTE("EOR");
 653       if ((cmp->flags & IOPARM_EOR))
 654         return true;
 655       break;
 656
 657     case LIBERROR_END:
 658       cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END");
 659       if ((cmp->flags & IOPARM_END))
 660         return true;
 661       break;
 662
 663     default:
 664       cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR");
 665       if ((cmp->flags & IOPARM_ERR))
 666         return true;
 667       break;
 668     }
 669
 670   /* Return if the user supplied an iostat variable.  */
 671   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 672     return true;
 673
 674   /* Return code, caller is responsible for terminating
 675    the program if necessary.  */
 676
 677   recursion_check ();
 678   show_locus (cmp);
 679   struct iovec iov[3];
 680   iov[0].iov_base = (char*) "Fortran runtime error: ";
 681   iov[0].iov_len = strlen (iov[0].iov_base);
 682   iov[1].iov_base = (char*) message;
 683   iov[1].iov_len = strlen (message);
 684   iov[2].iov_base = (char*) "\n";
 685   iov[2].iov_len = 1;
 686   estr_writev (iov, 3);
 687   return false;
 688 }
 689
 690 /* generate_error()-- Come here when an error happens.  This
 691  * subroutine is called if it is possible to continue on after the error.
 692  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 693  * ERR labels are present, we return, otherwise we terminate the program
 694  * after printing a message.  The error code is always required but the
 695  * message parameter can be NULL, in which case a string describing
 696  * the most recent operating system error is used.
 697  * If the error is for an asynchronous unit and if the program is currently
 698  * executing the asynchronous thread, just mark the error and return.  */
 699
 700 void
 701 generate_error (st_parameter_common *cmp, int family, const char *message)
 702 {
 703   if (generate_error_common (cmp, family, message))
 704     return;
 705
 706   exit_error(2);
 707 }
 708 iexport(generate_error);
 709
 710
 711 /* generate_warning()-- Similar to generate_error but just give a warning.  */
 712
 713 void
 714 generate_warning (st_parameter_common *cmp, const char *message)
 715 {
 716   if (message == NULL)
 717     message = " ";
 718
 719   show_locus (cmp);
 720   struct iovec iov[3];
 721   iov[0].iov_base = (char*) "Fortran runtime warning: ";
 722   iov[0].iov_len = strlen (iov[0].iov_base);
 723   iov[1].iov_base = (char*) message;
 724   iov[1].iov_len = strlen (message);
 725   iov[2].iov_base = (char*) "\n";
 726   iov[2].iov_len = 1;
 727   estr_writev (iov, 3);
 728 }
 729
 730
 731 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 732    we should issue an error or a warning, or be quiet.  */
 733
 734 notification
 735 notification_std (int std)
 736 {
 737   int warning;
 738
 739   if (!compile_options.pedantic)
 740     return NOTIFICATION_SILENT;
 741
 742   warning = compile_options.warn_std & std;
 743   if ((compile_options.allow_std & std) != 0 && !warning)
 744     return NOTIFICATION_SILENT;
 745
 746   return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
 747 }
 748
 749
 750 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 751    feature.  An error/warning will be issued if the currently selected
 752    standard does not contain the requested bits.  */
 753
 754 bool
 755 notify_std (st_parameter_common *cmp, int std, const char * message)
 756 {
 757   int warning;
 758   struct iovec iov[3];
 759
 760   if (!compile_options.pedantic)
 761     return true;
 762
 763   warning = compile_options.warn_std & std;
 764   if ((compile_options.allow_std & std) != 0 && !warning)
 765     return true;
 766
 767   if (!warning)
 768     {
 769       recursion_check ();
 770       show_locus (cmp);
 771       iov[0].iov_base = (char*) "Fortran runtime error: ";
 772       iov[0].iov_len = strlen (iov[0].iov_base);
 773       iov[1].iov_base = (char*) message;
 774       iov[1].iov_len = strlen (message);
 775       iov[2].iov_base = (char*) "\n";
 776       iov[2].iov_len = 1;
 777       estr_writev (iov, 3);
 778       exit_error (2);
 779     }
 780   else
 781     {
 782       show_locus (cmp);
 783       iov[0].iov_base = (char*) "Fortran runtime warning: ";
 784       iov[0].iov_len = strlen (iov[0].iov_base);
 785       iov[1].iov_base = (char*) message;
 786       iov[1].iov_len = strlen (message);
 787       iov[2].iov_base = (char*) "\n";
 788       iov[2].iov_len = 1;
 789       estr_writev (iov, 3);
 790     }
 791   return false;
 792 }