libgfortran/runtime/error.c

   1 /* Copyright (C) 2002-2017 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 <assert.h>
  28 #include <string.h>
  29 #include <errno.h>
  30 #include <signal.h>
  31
  32 #ifdef HAVE_UNISTD_H
  33 #include <unistd.h>
  34 #endif
  35
  36 #ifdef HAVE_SYS_TIME_H
  37 #include <sys/time.h>
  38 #endif
  39
  40 /* <sys/time.h> has to be included before <sys/resource.h> to work
  41    around PR 30518; otherwise, MacOS 10.3.9 headers are just broken.  */
  42 #ifdef HAVE_SYS_RESOURCE_H
  43 #include <sys/resource.h>
  44 #endif
  45
  46
  47 #include <locale.h>
  48
  49 #ifdef HAVE_XLOCALE_H
  50 #include <xlocale.h>
  51 #endif
  52
  53
  54 #ifdef __MINGW32__
  55 #define HAVE_GETPID 1
  56 #include <process.h>
  57 #endif
  58
  59
  60 /* Termination of a program: F2008 2.3.5 talks about "normal
  61    termination" and "error termination". Normal termination occurs as
  62    a result of e.g. executing the end program statement, and executing
  63    the STOP statement. It includes the effect of the C exit()
  64    function.
  65
  66    Error termination is initiated when the ERROR STOP statement is
  67    executed, when ALLOCATE/DEALLOCATE fails without STAT= being
  68    specified, when some of the co-array synchronization statements
  69    fail without STAT= being specified, and some I/O errors if
  70    ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE
  71    failure without CMDSTAT=.
  72
  73    2.3.5 also explains how co-images synchronize during termination.
  74
  75    In libgfortran we have three ways of ending a program. exit(code)
  76    is a normal exit; calling exit() also causes open units to be
  77    closed. No backtrace or core dump is needed here.  For error
  78    termination, we have exit_error(status), which prints a backtrace
  79    if backtracing is enabled, then exits.  Finally, when something
  80    goes terribly wrong, we have sys_abort() which tries to print the
  81    backtrace if -fbacktrace is enabled, and then dumps core; whether a
  82    core file is generated is system dependent. When aborting, we don't
  83    flush and close open units, as program memory might be corrupted
  84    and we'd rather risk losing dirty data in the buffers rather than
  85    corrupting files on disk.
  86
  87 */
  88
  89 /* Error conditions.  The tricky part here is printing a message when
  90  * it is the I/O subsystem that is severely wounded.  Our goal is to
  91  * try and print something making the fewest assumptions possible,
  92  * then try to clean up before actually exiting.
  93  *
  94  * The following exit conditions are defined:
  95  * 0    Normal program exit.
  96  * 1    Terminated because of operating system error.
  97  * 2    Error in the runtime library
  98  * 3    Internal error in runtime library
  99  *
 100  * Other error returns are reserved for the STOP statement with a numeric code.
 101  */
 102
 103
 104 /* Write a null-terminated C string to standard error. This function
 105    is async-signal-safe.  */
 106
 107 ssize_t
 108 estr_write (const char *str)
 109 {
 110   return write (STDERR_FILENO, str, strlen (str));
 111 }
 112
 113
 114 /* st_vprintf()-- vsnprintf-like function for error output.  We use a
 115    stack allocated buffer for formatting; since this function might be
 116    called from within a signal handler, printing directly to stderr
 117    with vfprintf is not safe since the stderr locking might lead to a
 118    deadlock.  */
 119
 120 #define ST_VPRINTF_SIZE 512
 121
 122 int
 123 st_vprintf (const char *format, va_list ap)
 124 {
 125   int written;
 126   char buffer[ST_VPRINTF_SIZE];
 127
 128 #ifdef HAVE_VSNPRINTF
 129   written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
 130 #else
 131   written = vsprintf(buffer, format, ap);
 132
 133   if (written >= ST_VPRINTF_SIZE - 1)
 134     {
 135       /* The error message was longer than our buffer.  Ouch.  Because
 136          we may have messed up things badly, report the error and
 137          quit.  */
 138 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
 139       write (STDERR_FILENO, buffer, ST_VPRINTF_SIZE - 1);
 140       write (STDERR_FILENO, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
 141       sys_abort ();
 142 #undef ERROR_MESSAGE
 143
 144     }
 145 #endif
 146
 147   written = write (STDERR_FILENO, buffer, written);
 148   return written;
 149 }
 150
 151
 152 int
 153 st_printf (const char * format, ...)
 154 {
 155   int written;
 156   va_list ap;
 157   va_start (ap, format);
 158   written = st_vprintf (format, ap);
 159   va_end (ap);
 160   return written;
 161 }
 162
 163
 164 /* sys_abort()-- Terminate the program showing backtrace and dumping
 165    core.  */
 166
 167 void
 168 sys_abort (void)
 169 {
 170   /* If backtracing is enabled, print backtrace and disable signal
 171      handler for ABRT.  */
 172   if (options.backtrace == 1
 173       || (options.backtrace == -1 && compile_options.backtrace == 1))
 174     {
 175       estr_write ("\nProgram aborted. Backtrace:\n");
 176       show_backtrace (false);
 177       signal (SIGABRT, SIG_DFL);
 178     }
 179
 180   abort();
 181 }
 182
 183
 184 /* Exit in case of error termination. If backtracing is enabled, print
 185    backtrace, then exit.  */
 186
 187 void
 188 exit_error (int status)
 189 {
 190   if (options.backtrace == 1
 191       || (options.backtrace == -1 && compile_options.backtrace == 1))
 192     {
 193       estr_write ("\nError termination. Backtrace:\n");
 194       show_backtrace (false);
 195     }
 196   exit (status);
 197 }
 198
 199
 200
 201 /* gfc_xtoa()-- Integer to hexadecimal conversion.  */
 202
 203 const char *
 204 gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 205 {
 206   int digit;
 207   char *p;
 208
 209   assert (len >= GFC_XTOA_BUF_SIZE);
 210
 211   if (n == 0)
 212     return "0";
 213
 214   p = buffer + GFC_XTOA_BUF_SIZE - 1;
 215   *p = '\0';
 216
 217   while (n != 0)
 218     {
 219       digit = n & 0xF;
 220       if (digit > 9)
 221         digit += 'A' - '0' - 10;
 222
 223       *--p = '0' + digit;
 224       n >>= 4;
 225     }
 226
 227   return p;
 228 }
 229
 230
 231 /* Hopefully thread-safe wrapper for a strerror() style function.  */
 232
 233 char *
 234 gf_strerror (int errnum,
 235              char * buf __attribute__((unused)),
 236              size_t buflen __attribute__((unused)))
 237 {
 238 #ifdef HAVE_STRERROR_L
 239   locale_t myloc = newlocale (LC_CTYPE_MASK | LC_MESSAGES_MASK, "",
 240                               (locale_t) 0);
 241   char *p;
 242   if (myloc)
 243     {
 244       p = strerror_l (errnum, myloc);
 245       freelocale (myloc);
 246     }
 247   else
 248     /* newlocale might fail e.g. due to running out of memory, fall
 249        back to the simpler strerror.  */
 250     p = strerror (errnum);
 251   return p;
 252 #elif defined(HAVE_STRERROR_R)
 253 #ifdef HAVE_USELOCALE
 254   /* Some targets (Darwin at least) have the POSIX 2008 extended
 255      locale functions, but not strerror_l.  So reset the per-thread
 256      locale here.  */
 257   uselocale (LC_GLOBAL_LOCALE);
 258 #endif
 259   /* POSIX returns an "int", GNU a "char*".  */
 260   return
 261     __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0))
 262                            == 5,
 263                            /* GNU strerror_r()  */
 264                            strerror_r (errnum, buf, buflen),
 265                            /* POSIX strerror_r ()  */
 266                            (strerror_r (errnum, buf, buflen), buf));
 267 #elif defined(HAVE_STRERROR_R_2ARGS)
 268   strerror_r (errnum, buf);
 269   return buf;
 270 #else
 271   /* strerror () is not necessarily thread-safe, but should at least
 272      be available everywhere.  */
 273   return strerror (errnum);
 274 #endif
 275 }
 276
 277
 278 /* show_locus()-- Print a line number and filename describing where
 279  * something went wrong */
 280
 281 void
 282 show_locus (st_parameter_common *cmp)
 283 {
 284   char *filename;
 285
 286   if (!options.locus || cmp == NULL || cmp->filename == NULL)
 287     return;
 288
 289   if (cmp->unit > 0)
 290     {
 291       filename = filename_from_unit (cmp->unit);
 292
 293       if (filename != NULL)
 294         {
 295           st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
 296                    (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
 297           free (filename);
 298         }
 299       else
 300         {
 301           st_printf ("At line %d of file %s (unit = %d)\n",
 302                    (int) cmp->line, cmp->filename, (int) cmp->unit);
 303         }
 304       return;
 305     }
 306
 307   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
 308 }
 309
 310
 311 /* recursion_check()-- It's possible for additional errors to occur
 312  * during fatal error processing.  We detect this condition here and
 313  * exit with code 4 immediately. */
 314
 315 #define MAGIC 0x20DE8101
 316
 317 static void
 318 recursion_check (void)
 319 {
 320   static int magic = 0;
 321
 322   /* Don't even try to print something at this point */
 323   if (magic == MAGIC)
 324     sys_abort ();
 325
 326   magic = MAGIC;
 327 }
 328
 329
 330 #define STRERR_MAXSZ 256
 331
 332 /* os_error()-- Operating system error.  We get a message from the
 333  * operating system, show it and leave.  Some operating system errors
 334  * are caught and processed by the library.  If not, we come here. */
 335
 336 void
 337 os_error (const char *message)
 338 {
 339   char errmsg[STRERR_MAXSZ];
 340   recursion_check ();
 341   estr_write ("Operating system error: ");
 342   estr_write (gf_strerror (errno, errmsg, STRERR_MAXSZ));
 343   estr_write ("\n");
 344   estr_write (message);
 345   estr_write ("\n");
 346   exit_error (1);
 347 }
 348 iexport(os_error);
 349
 350
 351 /* void runtime_error()-- These are errors associated with an
 352  * invalid fortran program. */
 353
 354 void
 355 runtime_error (const char *message, ...)
 356 {
 357   va_list ap;
 358
 359   recursion_check ();
 360   estr_write ("Fortran runtime error: ");
 361   va_start (ap, message);
 362   st_vprintf (message, ap);
 363   va_end (ap);
 364   estr_write ("\n");
 365   exit_error (2);
 366 }
 367 iexport(runtime_error);
 368
 369 /* void runtime_error_at()-- These are errors associated with a
 370  * run time error generated by the front end compiler.  */
 371
 372 void
 373 runtime_error_at (const char *where, const char *message, ...)
 374 {
 375   va_list ap;
 376
 377   recursion_check ();
 378   estr_write (where);
 379   estr_write ("\nFortran runtime error: ");
 380   va_start (ap, message);
 381   st_vprintf (message, ap);
 382   va_end (ap);
 383   estr_write ("\n");
 384   exit_error (2);
 385 }
 386 iexport(runtime_error_at);
 387
 388
 389 void
 390 runtime_warning_at (const char *where, const char *message, ...)
 391 {
 392   va_list ap;
 393
 394   estr_write (where);
 395   estr_write ("\nFortran runtime warning: ");
 396   va_start (ap, message);
 397   st_vprintf (message, ap);
 398   va_end (ap);
 399   estr_write ("\n");
 400 }
 401 iexport(runtime_warning_at);
 402
 403
 404 /* void internal_error()-- These are this-can't-happen errors
 405  * that indicate something deeply wrong. */
 406
 407 void
 408 internal_error (st_parameter_common *cmp, const char *message)
 409 {
 410   recursion_check ();
 411   show_locus (cmp);
 412   estr_write ("Internal Error: ");
 413   estr_write (message);
 414   estr_write ("\n");
 415
 416   /* This function call is here to get the main.o object file included
 417      when linking statically. This works because error.o is supposed to
 418      be always linked in (and the function call is in internal_error
 419      because hopefully it doesn't happen too often).  */
 420   stupid_function_name_for_static_linking();
 421
 422  exit_error (3);
 423 }
 424
 425
 426 /* translate_error()-- Given an integer error code, return a string
 427  * describing the error. */
 428
 429 const char *
 430 translate_error (int code)
 431 {
 432   const char *p;
 433
 434   switch (code)
 435     {
 436     case LIBERROR_EOR:
 437       p = "End of record";
 438       break;
 439
 440     case LIBERROR_END:
 441       p = "End of file";
 442       break;
 443
 444     case LIBERROR_OK:
 445       p = "Successful return";
 446       break;
 447
 448     case LIBERROR_OS:
 449       p = "Operating system error";
 450       break;
 451
 452     case LIBERROR_BAD_OPTION:
 453       p = "Bad statement option";
 454       break;
 455
 456     case LIBERROR_MISSING_OPTION:
 457       p = "Missing statement option";
 458       break;
 459
 460     case LIBERROR_OPTION_CONFLICT:
 461       p = "Conflicting statement options";
 462       break;
 463
 464     case LIBERROR_ALREADY_OPEN:
 465       p = "File already opened in another unit";
 466       break;
 467
 468     case LIBERROR_BAD_UNIT:
 469       p = "Unattached unit";
 470       break;
 471
 472     case LIBERROR_FORMAT:
 473       p = "FORMAT error";
 474       break;
 475
 476     case LIBERROR_BAD_ACTION:
 477       p = "Incorrect ACTION specified";
 478       break;
 479
 480     case LIBERROR_ENDFILE:
 481       p = "Read past ENDFILE record";
 482       break;
 483
 484     case LIBERROR_BAD_US:
 485       p = "Corrupt unformatted sequential file";
 486       break;
 487
 488     case LIBERROR_READ_VALUE:
 489       p = "Bad value during read";
 490       break;
 491
 492     case LIBERROR_READ_OVERFLOW:
 493       p = "Numeric overflow on read";
 494       break;
 495
 496     case LIBERROR_INTERNAL:
 497       p = "Internal error in run-time library";
 498       break;
 499
 500     case LIBERROR_INTERNAL_UNIT:
 501       p = "Internal unit I/O error";
 502       break;
 503
 504     case LIBERROR_DIRECT_EOR:
 505       p = "Write exceeds length of DIRECT access record";
 506       break;
 507
 508     case LIBERROR_SHORT_RECORD:
 509       p = "I/O past end of record on unformatted file";
 510       break;
 511
 512     case LIBERROR_CORRUPT_FILE:
 513       p = "Unformatted file structure has been corrupted";
 514       break;
 515
 516     case LIBERROR_INQUIRE_INTERNAL_UNIT:
 517       p = "Inquire statement identifies an internal file";
 518       break;
 519
 520     default:
 521       p = "Unknown error code";
 522       break;
 523     }
 524
 525   return p;
 526 }
 527
 528
 529 /* generate_error()-- Come here when an error happens.  This
 530  * subroutine is called if it is possible to continue on after the error.
 531  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 532  * ERR labels are present, we return, otherwise we terminate the program
 533  * after printing a message.  The error code is always required but the
 534  * message parameter can be NULL, in which case a string describing
 535  * the most recent operating system error is used. */
 536
 537 void
 538 generate_error (st_parameter_common *cmp, int family, const char *message)
 539 {
 540   char errmsg[STRERR_MAXSZ];
 541
 542   /* If there was a previous error, don't mask it with another
 543      error message, EOF or EOR condition.  */
 544
 545   if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
 546     return;
 547
 548   /* Set the error status.  */
 549   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 550     *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
 551
 552   if (message == NULL)
 553     message =
 554       (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
 555       translate_error (family);
 556
 557   if (cmp->flags & IOPARM_HAS_IOMSG)
 558     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 559
 560   /* Report status back to the compiler.  */
 561   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 562   switch (family)
 563     {
 564     case LIBERROR_EOR:
 565       cmp->flags |= IOPARM_LIBRETURN_EOR;
 566       if ((cmp->flags & IOPARM_EOR))
 567         return;
 568       break;
 569
 570     case LIBERROR_END:
 571       cmp->flags |= IOPARM_LIBRETURN_END;
 572       if ((cmp->flags & IOPARM_END))
 573         return;
 574       break;
 575
 576     default:
 577       cmp->flags |= IOPARM_LIBRETURN_ERROR;
 578       if ((cmp->flags & IOPARM_ERR))
 579         return;
 580       break;
 581     }
 582
 583   /* Return if the user supplied an iostat variable.  */
 584   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 585     return;
 586
 587   /* Terminate the program */
 588
 589   recursion_check ();
 590   show_locus (cmp);
 591   estr_write ("Fortran runtime error: ");
 592   estr_write (message);
 593   estr_write ("\n");
 594   exit_error (2);
 595 }
 596 iexport(generate_error);
 597
 598
 599 /* generate_warning()-- Similar to generate_error but just give a warning.  */
 600
 601 void
 602 generate_warning (st_parameter_common *cmp, const char *message)
 603 {
 604   if (message == NULL)
 605     message = " ";
 606
 607   show_locus (cmp);
 608   estr_write ("Fortran runtime warning: ");
 609   estr_write (message);
 610   estr_write ("\n");
 611 }
 612
 613
 614 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 615    we should issue an error or a warning, or be quiet.  */
 616
 617 notification
 618 notification_std (int std)
 619 {
 620   int warning;
 621
 622   if (!compile_options.pedantic)
 623     return NOTIFICATION_SILENT;
 624
 625   warning = compile_options.warn_std & std;
 626   if ((compile_options.allow_std & std) != 0 && !warning)
 627     return NOTIFICATION_SILENT;
 628
 629   return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
 630 }
 631
 632
 633 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 634    feature.  An error/warning will be issued if the currently selected
 635    standard does not contain the requested bits.  */
 636
 637 bool
 638 notify_std (st_parameter_common *cmp, int std, const char * message)
 639 {
 640   int warning;
 641
 642   if (!compile_options.pedantic)
 643     return true;
 644
 645   warning = compile_options.warn_std & std;
 646   if ((compile_options.allow_std & std) != 0 && !warning)
 647     return true;
 648
 649   if (!warning)
 650     {
 651       recursion_check ();
 652       show_locus (cmp);
 653       estr_write ("Fortran runtime error: ");
 654       estr_write (message);
 655       estr_write ("\n");
 656       exit_error (2);
 657     }
 658   else
 659     {
 660       show_locus (cmp);
 661       estr_write ("Fortran runtime warning: ");
 662       estr_write (message);
 663       estr_write ("\n");
 664     }
 665   return false;
 666 }