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 /* st_vprintf()-- vsnprintf-like function for error output.  We use a
 118    stack allocated buffer for formatting; since this function might be
 119    called from within a signal handler, printing directly to stderr
 120    with vfprintf is not safe since the stderr locking might lead to a
 121    deadlock.  */
 122
 123 #define ST_VPRINTF_SIZE 512
 124
 125 int
 126 st_vprintf (const char *format, va_list ap)
 127 {
 128   int written;
 129   char buffer[ST_VPRINTF_SIZE];
 130
 131 #ifdef HAVE_VSNPRINTF
 132   written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
 133 #else
 134   written = vsprintf(buffer, format, ap);
 135
 136   if (written >= ST_VPRINTF_SIZE - 1)
 137     {
 138       /* The error message was longer than our buffer.  Ouch.  Because
 139          we may have messed up things badly, report the error and
 140          quit.  */
 141 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
 142       write (STDERR_FILENO, buffer, ST_VPRINTF_SIZE - 1);
 143       write (STDERR_FILENO, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
 144       sys_abort ();
 145 #undef ERROR_MESSAGE
 146
 147     }
 148 #endif
 149
 150   written = write (STDERR_FILENO, buffer, written);
 151   return written;
 152 }
 153
 154
 155 int
 156 st_printf (const char * format, ...)
 157 {
 158   int written;
 159   va_list ap;
 160   va_start (ap, format);
 161   written = st_vprintf (format, ap);
 162   va_end (ap);
 163   return written;
 164 }
 165
 166
 167 /* sys_abort()-- Terminate the program showing backtrace and dumping
 168    core.  */
 169
 170 void
 171 sys_abort (void)
 172 {
 173   /* If backtracing is enabled, print backtrace and disable signal
 174      handler for ABRT.  */
 175   if (options.backtrace == 1
 176       || (options.backtrace == -1 && compile_options.backtrace == 1))
 177     {
 178       estr_write ("\nProgram aborted. Backtrace:\n");
 179       show_backtrace (false);
 180       signal (SIGABRT, SIG_DFL);
 181     }
 182
 183   abort();
 184 }
 185
 186
 187 /* Exit in case of error termination. If backtracing is enabled, print
 188    backtrace, then exit.  */
 189
 190 void
 191 exit_error (int status)
 192 {
 193   if (options.backtrace == 1
 194       || (options.backtrace == -1 && compile_options.backtrace == 1))
 195     {
 196       estr_write ("\nError termination. Backtrace:\n");
 197       show_backtrace (false);
 198     }
 199   exit (status);
 200 }
 201
 202
 203
 204 /* gfc_xtoa()-- Integer to hexadecimal conversion.  */
 205
 206 const char *
 207 gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 208 {
 209   int digit;
 210   char *p;
 211
 212   assert (len >= GFC_XTOA_BUF_SIZE);
 213
 214   if (n == 0)
 215     return "0";
 216
 217   p = buffer + GFC_XTOA_BUF_SIZE - 1;
 218   *p = '\0';
 219
 220   while (n != 0)
 221     {
 222       digit = n & 0xF;
 223       if (digit > 9)
 224         digit += 'A' - '0' - 10;
 225
 226       *--p = '0' + digit;
 227       n >>= 4;
 228     }
 229
 230   return p;
 231 }
 232
 233
 234 /* Hopefully thread-safe wrapper for a strerror() style function.  */
 235
 236 char *
 237 gf_strerror (int errnum,
 238              char * buf __attribute__((unused)),
 239              size_t buflen __attribute__((unused)))
 240 {
 241 #ifdef HAVE_STRERROR_L
 242   locale_t myloc = newlocale (LC_CTYPE_MASK | LC_MESSAGES_MASK, "",
 243                               (locale_t) 0);
 244   char *p;
 245   if (myloc)
 246     {
 247       p = strerror_l (errnum, myloc);
 248       freelocale (myloc);
 249     }
 250   else
 251     /* newlocale might fail e.g. due to running out of memory, fall
 252        back to the simpler strerror.  */
 253     p = strerror (errnum);
 254   return p;
 255 #elif defined(HAVE_STRERROR_R)
 256 #ifdef HAVE_USELOCALE
 257   /* Some targets (Darwin at least) have the POSIX 2008 extended
 258      locale functions, but not strerror_l.  So reset the per-thread
 259      locale here.  */
 260   uselocale (LC_GLOBAL_LOCALE);
 261 #endif
 262   /* POSIX returns an "int", GNU a "char*".  */
 263   return
 264     __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0))
 265                            == 5,
 266                            /* GNU strerror_r()  */
 267                            strerror_r (errnum, buf, buflen),
 268                            /* POSIX strerror_r ()  */
 269                            (strerror_r (errnum, buf, buflen), buf));
 270 #elif defined(HAVE_STRERROR_R_2ARGS)
 271   strerror_r (errnum, buf);
 272   return buf;
 273 #else
 274   /* strerror () is not necessarily thread-safe, but should at least
 275      be available everywhere.  */
 276   return strerror (errnum);
 277 #endif
 278 }
 279
 280
 281 /* show_locus()-- Print a line number and filename describing where
 282  * something went wrong */
 283
 284 void
 285 show_locus (st_parameter_common *cmp)
 286 {
 287   char *filename;
 288
 289   if (!options.locus || cmp == NULL || cmp->filename == NULL)
 290     return;
 291
 292   if (cmp->unit > 0)
 293     {
 294       filename = filename_from_unit (cmp->unit);
 295
 296       if (filename != NULL)
 297         {
 298           st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
 299                    (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
 300           free (filename);
 301         }
 302       else
 303         {
 304           st_printf ("At line %d of file %s (unit = %d)\n",
 305                    (int) cmp->line, cmp->filename, (int) cmp->unit);
 306         }
 307       return;
 308     }
 309
 310   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
 311 }
 312
 313
 314 /* recursion_check()-- It's possible for additional errors to occur
 315  * during fatal error processing.  We detect this condition here and
 316  * exit with code 4 immediately. */
 317
 318 #define MAGIC 0x20DE8101
 319
 320 static void
 321 recursion_check (void)
 322 {
 323   static int magic = 0;
 324
 325   /* Don't even try to print something at this point */
 326   if (magic == MAGIC)
 327     sys_abort ();
 328
 329   magic = MAGIC;
 330 }
 331
 332
 333 #define STRERR_MAXSZ 256
 334
 335 /* os_error()-- Operating system error.  We get a message from the
 336  * operating system, show it and leave.  Some operating system errors
 337  * are caught and processed by the library.  If not, we come here. */
 338
 339 void
 340 os_error (const char *message)
 341 {
 342   char errmsg[STRERR_MAXSZ];
 343   recursion_check ();
 344   estr_write ("Operating system error: ");
 345   estr_write (gf_strerror (errno, errmsg, STRERR_MAXSZ));
 346   estr_write ("\n");
 347   estr_write (message);
 348   estr_write ("\n");
 349   exit_error (1);
 350 }
 351 iexport(os_error);
 352
 353
 354 /* void runtime_error()-- These are errors associated with an
 355  * invalid fortran program. */
 356
 357 void
 358 runtime_error (const char *message, ...)
 359 {
 360   va_list ap;
 361
 362   recursion_check ();
 363   estr_write ("Fortran runtime error: ");
 364   va_start (ap, message);
 365   st_vprintf (message, ap);
 366   va_end (ap);
 367   estr_write ("\n");
 368   exit_error (2);
 369 }
 370 iexport(runtime_error);
 371
 372 /* void runtime_error_at()-- These are errors associated with a
 373  * run time error generated by the front end compiler.  */
 374
 375 void
 376 runtime_error_at (const char *where, const char *message, ...)
 377 {
 378   va_list ap;
 379
 380   recursion_check ();
 381   estr_write (where);
 382   estr_write ("\nFortran runtime error: ");
 383   va_start (ap, message);
 384   st_vprintf (message, ap);
 385   va_end (ap);
 386   estr_write ("\n");
 387   exit_error (2);
 388 }
 389 iexport(runtime_error_at);
 390
 391
 392 void
 393 runtime_warning_at (const char *where, const char *message, ...)
 394 {
 395   va_list ap;
 396
 397   estr_write (where);
 398   estr_write ("\nFortran runtime warning: ");
 399   va_start (ap, message);
 400   st_vprintf (message, ap);
 401   va_end (ap);
 402   estr_write ("\n");
 403 }
 404 iexport(runtime_warning_at);
 405
 406
 407 /* void internal_error()-- These are this-can't-happen errors
 408  * that indicate something deeply wrong. */
 409
 410 void
 411 internal_error (st_parameter_common *cmp, const char *message)
 412 {
 413   recursion_check ();
 414   show_locus (cmp);
 415   estr_write ("Internal Error: ");
 416   estr_write (message);
 417   estr_write ("\n");
 418
 419   /* This function call is here to get the main.o object file included
 420      when linking statically. This works because error.o is supposed to
 421      be always linked in (and the function call is in internal_error
 422      because hopefully it doesn't happen too often).  */
 423   stupid_function_name_for_static_linking();
 424
 425  exit_error (3);
 426 }
 427
 428
 429 /* translate_error()-- Given an integer error code, return a string
 430  * describing the error. */
 431
 432 const char *
 433 translate_error (int code)
 434 {
 435   const char *p;
 436
 437   switch (code)
 438     {
 439     case LIBERROR_EOR:
 440       p = "End of record";
 441       break;
 442
 443     case LIBERROR_END:
 444       p = "End of file";
 445       break;
 446
 447     case LIBERROR_OK:
 448       p = "Successful return";
 449       break;
 450
 451     case LIBERROR_OS:
 452       p = "Operating system error";
 453       break;
 454
 455     case LIBERROR_BAD_OPTION:
 456       p = "Bad statement option";
 457       break;
 458
 459     case LIBERROR_MISSING_OPTION:
 460       p = "Missing statement option";
 461       break;
 462
 463     case LIBERROR_OPTION_CONFLICT:
 464       p = "Conflicting statement options";
 465       break;
 466
 467     case LIBERROR_ALREADY_OPEN:
 468       p = "File already opened in another unit";
 469       break;
 470
 471     case LIBERROR_BAD_UNIT:
 472       p = "Unattached unit";
 473       break;
 474
 475     case LIBERROR_FORMAT:
 476       p = "FORMAT error";
 477       break;
 478
 479     case LIBERROR_BAD_ACTION:
 480       p = "Incorrect ACTION specified";
 481       break;
 482
 483     case LIBERROR_ENDFILE:
 484       p = "Read past ENDFILE record";
 485       break;
 486
 487     case LIBERROR_BAD_US:
 488       p = "Corrupt unformatted sequential file";
 489       break;
 490
 491     case LIBERROR_READ_VALUE:
 492       p = "Bad value during read";
 493       break;
 494
 495     case LIBERROR_READ_OVERFLOW:
 496       p = "Numeric overflow on read";
 497       break;
 498
 499     case LIBERROR_INTERNAL:
 500       p = "Internal error in run-time library";
 501       break;
 502
 503     case LIBERROR_INTERNAL_UNIT:
 504       p = "Internal unit I/O error";
 505       break;
 506
 507     case LIBERROR_DIRECT_EOR:
 508       p = "Write exceeds length of DIRECT access record";
 509       break;
 510
 511     case LIBERROR_SHORT_RECORD:
 512       p = "I/O past end of record on unformatted file";
 513       break;
 514
 515     case LIBERROR_CORRUPT_FILE:
 516       p = "Unformatted file structure has been corrupted";
 517       break;
 518
 519     case LIBERROR_INQUIRE_INTERNAL_UNIT:
 520       p = "Inquire statement identifies an internal file";
 521       break;
 522
 523     default:
 524       p = "Unknown error code";
 525       break;
 526     }
 527
 528   return p;
 529 }
 530
 531
 532 /* Worker function for generate_error and generate_error_async.  Return true
 533    if a straight return is to be done, zero if the program should abort. */
 534
 535 bool
 536 generate_error_common (st_parameter_common *cmp, int family, const char *message)
 537 {
 538   char errmsg[STRERR_MAXSZ];
 539   gfc_unit *u;
 540
 541   NOTE ("Entering generate_error_common");
 542
 543   u = thread_unit;
 544   if (u && u->au)
 545     {
 546       if (u->au->error.has_error)
 547         return true;
 548
 549       if (__gthread_equal (u->au->thread, __gthread_self ()))
 550         {
 551           u->au->error.has_error = 1;
 552           u->au->error.cmp = cmp;
 553           u->au->error.family = family;
 554           u->au->error.message = message;
 555           return true;
 556         }
 557     }
 558
 559   /* If there was a previous error, don't mask it with another
 560      error message, EOF or EOR condition.  */
 561
 562   if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
 563     return true;
 564
 565   /* Set the error status.  */
 566   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 567     *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
 568
 569   if (message == NULL)
 570     message =
 571       (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
 572       translate_error (family);
 573
 574   if (cmp->flags & IOPARM_HAS_IOMSG)
 575     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 576
 577   /* Report status back to the compiler.  */
 578   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 579   switch (family)
 580     {
 581     case LIBERROR_EOR:
 582       cmp->flags |= IOPARM_LIBRETURN_EOR;  NOTE("EOR");
 583       if ((cmp->flags & IOPARM_EOR))
 584         return true;
 585       break;
 586
 587     case LIBERROR_END:
 588       cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END");
 589       if ((cmp->flags & IOPARM_END))
 590         return true;
 591       break;
 592
 593     default:
 594       cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR");
 595       if ((cmp->flags & IOPARM_ERR))
 596         return true;
 597       break;
 598     }
 599
 600   /* Return if the user supplied an iostat variable.  */
 601   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 602     return true;
 603
 604   /* Return code, caller is responsible for terminating
 605    the program if necessary.  */
 606
 607   recursion_check ();
 608   show_locus (cmp);
 609   estr_write ("Fortran runtime error: ");
 610   estr_write (message);
 611   estr_write ("\n");
 612   return false;
 613 }
 614
 615 /* generate_error()-- Come here when an error happens.  This
 616  * subroutine is called if it is possible to continue on after the error.
 617  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 618  * ERR labels are present, we return, otherwise we terminate the program
 619  * after printing a message.  The error code is always required but the
 620  * message parameter can be NULL, in which case a string describing
 621  * the most recent operating system error is used.
 622  * If the error is for an asynchronous unit and if the program is currently
 623  * executing the asynchronous thread, just mark the error and return.  */
 624
 625 void
 626 generate_error (st_parameter_common *cmp, int family, const char *message)
 627 {
 628   if (generate_error_common (cmp, family, message))
 629     return;
 630
 631   exit_error(2);
 632 }
 633 iexport(generate_error);
 634
 635
 636 /* generate_warning()-- Similar to generate_error but just give a warning.  */
 637
 638 void
 639 generate_warning (st_parameter_common *cmp, const char *message)
 640 {
 641   if (message == NULL)
 642     message = " ";
 643
 644   show_locus (cmp);
 645   estr_write ("Fortran runtime warning: ");
 646   estr_write (message);
 647   estr_write ("\n");
 648 }
 649
 650
 651 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 652    we should issue an error or a warning, or be quiet.  */
 653
 654 notification
 655 notification_std (int std)
 656 {
 657   int warning;
 658
 659   if (!compile_options.pedantic)
 660     return NOTIFICATION_SILENT;
 661
 662   warning = compile_options.warn_std & std;
 663   if ((compile_options.allow_std & std) != 0 && !warning)
 664     return NOTIFICATION_SILENT;
 665
 666   return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
 667 }
 668
 669
 670 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 671    feature.  An error/warning will be issued if the currently selected
 672    standard does not contain the requested bits.  */
 673
 674 bool
 675 notify_std (st_parameter_common *cmp, int std, const char * message)
 676 {
 677   int warning;
 678
 679   if (!compile_options.pedantic)
 680     return true;
 681
 682   warning = compile_options.warn_std & std;
 683   if ((compile_options.allow_std & std) != 0 && !warning)
 684     return true;
 685
 686   if (!warning)
 687     {
 688       recursion_check ();
 689       show_locus (cmp);
 690       estr_write ("Fortran runtime error: ");
 691       estr_write (message);
 692       estr_write ("\n");
 693       exit_error (2);
 694     }
 695   else
 696     {
 697       show_locus (cmp);
 698       estr_write ("Fortran runtime warning: ");
 699       estr_write (message);
 700       estr_write ("\n");
 701     }
 702   return false;
 703 }