libgfortran/runtime/error.c

   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 }