libgfortran/runtime/error.c

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