libgfortran/runtime/error.c

   1 /* Copyright (C) 2002-2015 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 two ways of ending a program. exit(code) is
  78    a normal exit; calling exit() also causes open units to be
  79    closed. No backtrace or core dump is needed here. When something
  80    goes wrong, we have sys_abort() which tries to print the backtrace
  81    if -fbacktrace is enabled, and then dumps core; whether a core file
  82    is generated is system dependent. When aborting, we don't flush and
  83    close open units, as program memory might be corrupted and we'd
  84    rather risk losing dirty data in the buffers rather than corrupting
  85    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 /* gfc_xtoa()-- Integer to hexadecimal conversion.  */
 185
 186 const char *
 187 gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 188 {
 189   int digit;
 190   char *p;
 191
 192   assert (len >= GFC_XTOA_BUF_SIZE);
 193
 194   if (n == 0)
 195     return "0";
 196
 197   p = buffer + GFC_XTOA_BUF_SIZE - 1;
 198   *p = '\0';
 199
 200   while (n != 0)
 201     {
 202       digit = n & 0xF;
 203       if (digit > 9)
 204         digit += 'A' - '0' - 10;
 205
 206       *--p = '0' + digit;
 207       n >>= 4;
 208     }
 209
 210   return p;
 211 }
 212
 213
 214 /* Hopefully thread-safe wrapper for a strerror() style function.  */
 215
 216 char *
 217 gf_strerror (int errnum,
 218              char * buf __attribute__((unused)),
 219              size_t buflen __attribute__((unused)))
 220 {
 221 #ifdef HAVE_STRERROR_L
 222   locale_t myloc = newlocale (LC_CTYPE_MASK | LC_MESSAGES_MASK, "",
 223                               (locale_t) 0);
 224   char *p;
 225   if (myloc)
 226     {
 227       p = strerror_l (errnum, myloc);
 228       freelocale (myloc);
 229     }
 230   else
 231     /* newlocale might fail e.g. due to running out of memory, fall
 232        back to the simpler strerror.  */
 233     p = strerror (errnum);
 234   return p;
 235 #elif defined(HAVE_STRERROR_R)
 236 #ifdef HAVE_USELOCALE
 237   /* Some targets (Darwin at least) have the POSIX 2008 extended
 238      locale functions, but not strerror_l.  So reset the per-thread
 239      locale here.  */
 240   uselocale (LC_GLOBAL_LOCALE);
 241 #endif
 242   /* POSIX returns an "int", GNU a "char*".  */
 243   return
 244     __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0))
 245                            == 5,
 246                            /* GNU strerror_r()  */
 247                            strerror_r (errnum, buf, buflen),
 248                            /* POSIX strerror_r ()  */
 249                            (strerror_r (errnum, buf, buflen), buf));
 250 #elif defined(HAVE_STRERROR_R_2ARGS)
 251   strerror_r (errnum, buf);
 252   return buf;
 253 #else
 254   /* strerror () is not necessarily thread-safe, but should at least
 255      be available everywhere.  */
 256   return strerror (errnum);
 257 #endif
 258 }
 259
 260
 261 /* show_locus()-- Print a line number and filename describing where
 262  * something went wrong */
 263
 264 void
 265 show_locus (st_parameter_common *cmp)
 266 {
 267   char *filename;
 268
 269   if (!options.locus || cmp == NULL || cmp->filename == NULL)
 270     return;
 271
 272   if (cmp->unit > 0)
 273     {
 274       filename = filename_from_unit (cmp->unit);
 275
 276       if (filename != NULL)
 277         {
 278           st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
 279                    (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
 280           free (filename);
 281         }
 282       else
 283         {
 284           st_printf ("At line %d of file %s (unit = %d)\n",
 285                    (int) cmp->line, cmp->filename, (int) cmp->unit);
 286         }
 287       return;
 288     }
 289
 290   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
 291 }
 292
 293
 294 /* recursion_check()-- It's possible for additional errors to occur
 295  * during fatal error processing.  We detect this condition here and
 296  * exit with code 4 immediately. */
 297
 298 #define MAGIC 0x20DE8101
 299
 300 static void
 301 recursion_check (void)
 302 {
 303   static int magic = 0;
 304
 305   /* Don't even try to print something at this point */
 306   if (magic == MAGIC)
 307     sys_abort ();
 308
 309   magic = MAGIC;
 310 }
 311
 312
 313 #define STRERR_MAXSZ 256
 314
 315 /* os_error()-- Operating system error.  We get a message from the
 316  * operating system, show it and leave.  Some operating system errors
 317  * are caught and processed by the library.  If not, we come here. */
 318
 319 void
 320 os_error (const char *message)
 321 {
 322   char errmsg[STRERR_MAXSZ];
 323   recursion_check ();
 324   estr_write ("Operating system error: ");
 325   estr_write (gf_strerror (errno, errmsg, STRERR_MAXSZ));
 326   estr_write ("\n");
 327   estr_write (message);
 328   estr_write ("\n");
 329   exit (1);
 330 }
 331 iexport(os_error);
 332
 333
 334 /* void runtime_error()-- These are errors associated with an
 335  * invalid fortran program. */
 336
 337 void
 338 runtime_error (const char *message, ...)
 339 {
 340   va_list ap;
 341
 342   recursion_check ();
 343   estr_write ("Fortran runtime error: ");
 344   va_start (ap, message);
 345   st_vprintf (message, ap);
 346   va_end (ap);
 347   estr_write ("\n");
 348   exit (2);
 349 }
 350 iexport(runtime_error);
 351
 352 /* void runtime_error_at()-- These are errors associated with a
 353  * run time error generated by the front end compiler.  */
 354
 355 void
 356 runtime_error_at (const char *where, const char *message, ...)
 357 {
 358   va_list ap;
 359
 360   recursion_check ();
 361   estr_write (where);
 362   estr_write ("\nFortran runtime error: ");
 363   va_start (ap, message);
 364   st_vprintf (message, ap);
 365   va_end (ap);
 366   estr_write ("\n");
 367   exit (2);
 368 }
 369 iexport(runtime_error_at);
 370
 371
 372 void
 373 runtime_warning_at (const char *where, const char *message, ...)
 374 {
 375   va_list ap;
 376
 377   estr_write (where);
 378   estr_write ("\nFortran runtime warning: ");
 379   va_start (ap, message);
 380   st_vprintf (message, ap);
 381   va_end (ap);
 382   estr_write ("\n");
 383 }
 384 iexport(runtime_warning_at);
 385
 386
 387 /* void internal_error()-- These are this-can't-happen errors
 388  * that indicate something deeply wrong. */
 389
 390 void
 391 internal_error (st_parameter_common *cmp, const char *message)
 392 {
 393   recursion_check ();
 394   show_locus (cmp);
 395   estr_write ("Internal Error: ");
 396   estr_write (message);
 397   estr_write ("\n");
 398
 399   /* This function call is here to get the main.o object file included
 400      when linking statically. This works because error.o is supposed to
 401      be always linked in (and the function call is in internal_error
 402      because hopefully it doesn't happen too often).  */
 403   stupid_function_name_for_static_linking();
 404
 405   exit (3);
 406 }
 407
 408
 409 /* translate_error()-- Given an integer error code, return a string
 410  * describing the error. */
 411
 412 const char *
 413 translate_error (int code)
 414 {
 415   const char *p;
 416
 417   switch (code)
 418     {
 419     case LIBERROR_EOR:
 420       p = "End of record";
 421       break;
 422
 423     case LIBERROR_END:
 424       p = "End of file";
 425       break;
 426
 427     case LIBERROR_OK:
 428       p = "Successful return";
 429       break;
 430
 431     case LIBERROR_OS:
 432       p = "Operating system error";
 433       break;
 434
 435     case LIBERROR_BAD_OPTION:
 436       p = "Bad statement option";
 437       break;
 438
 439     case LIBERROR_MISSING_OPTION:
 440       p = "Missing statement option";
 441       break;
 442
 443     case LIBERROR_OPTION_CONFLICT:
 444       p = "Conflicting statement options";
 445       break;
 446
 447     case LIBERROR_ALREADY_OPEN:
 448       p = "File already opened in another unit";
 449       break;
 450
 451     case LIBERROR_BAD_UNIT:
 452       p = "Unattached unit";
 453       break;
 454
 455     case LIBERROR_FORMAT:
 456       p = "FORMAT error";
 457       break;
 458
 459     case LIBERROR_BAD_ACTION:
 460       p = "Incorrect ACTION specified";
 461       break;
 462
 463     case LIBERROR_ENDFILE:
 464       p = "Read past ENDFILE record";
 465       break;
 466
 467     case LIBERROR_BAD_US:
 468       p = "Corrupt unformatted sequential file";
 469       break;
 470
 471     case LIBERROR_READ_VALUE:
 472       p = "Bad value during read";
 473       break;
 474
 475     case LIBERROR_READ_OVERFLOW:
 476       p = "Numeric overflow on read";
 477       break;
 478
 479     case LIBERROR_INTERNAL:
 480       p = "Internal error in run-time library";
 481       break;
 482
 483     case LIBERROR_INTERNAL_UNIT:
 484       p = "Internal unit I/O error";
 485       break;
 486
 487     case LIBERROR_DIRECT_EOR:
 488       p = "Write exceeds length of DIRECT access record";
 489       break;
 490
 491     case LIBERROR_SHORT_RECORD:
 492       p = "I/O past end of record on unformatted file";
 493       break;
 494
 495     case LIBERROR_CORRUPT_FILE:
 496       p = "Unformatted file structure has been corrupted";
 497       break;
 498
 499     case LIBERROR_INQUIRE_INTERNAL_UNIT:
 500       p = "Inquire statement identifies an internal file";
 501       break;
 502
 503     default:
 504       p = "Unknown error code";
 505       break;
 506     }
 507
 508   return p;
 509 }
 510
 511
 512 /* generate_error()-- Come here when an error happens.  This
 513  * subroutine is called if it is possible to continue on after the error.
 514  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 515  * ERR labels are present, we return, otherwise we terminate the program
 516  * after printing a message.  The error code is always required but the
 517  * message parameter can be NULL, in which case a string describing
 518  * the most recent operating system error is used. */
 519
 520 void
 521 generate_error (st_parameter_common *cmp, int family, const char *message)
 522 {
 523   char errmsg[STRERR_MAXSZ];
 524
 525   /* If there was a previous error, don't mask it with another
 526      error message, EOF or EOR condition.  */
 527
 528   if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
 529     return;
 530
 531   /* Set the error status.  */
 532   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 533     *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
 534
 535   if (message == NULL)
 536     message =
 537       (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
 538       translate_error (family);
 539
 540   if (cmp->flags & IOPARM_HAS_IOMSG)
 541     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 542
 543   /* Report status back to the compiler.  */
 544   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 545   switch (family)
 546     {
 547     case LIBERROR_EOR:
 548       cmp->flags |= IOPARM_LIBRETURN_EOR;
 549       if ((cmp->flags & IOPARM_EOR))
 550         return;
 551       break;
 552
 553     case LIBERROR_END:
 554       cmp->flags |= IOPARM_LIBRETURN_END;
 555       if ((cmp->flags & IOPARM_END))
 556         return;
 557       break;
 558
 559     default:
 560       cmp->flags |= IOPARM_LIBRETURN_ERROR;
 561       if ((cmp->flags & IOPARM_ERR))
 562         return;
 563       break;
 564     }
 565
 566   /* Return if the user supplied an iostat variable.  */
 567   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 568     return;
 569
 570   /* Terminate the program */
 571
 572   recursion_check ();
 573   show_locus (cmp);
 574   estr_write ("Fortran runtime error: ");
 575   estr_write (message);
 576   estr_write ("\n");
 577   exit (2);
 578 }
 579 iexport(generate_error);
 580
 581
 582 /* generate_warning()-- Similar to generate_error but just give a warning.  */
 583
 584 void
 585 generate_warning (st_parameter_common *cmp, const char *message)
 586 {
 587   if (message == NULL)
 588     message = " ";
 589
 590   show_locus (cmp);
 591   estr_write ("Fortran runtime warning: ");
 592   estr_write (message);
 593   estr_write ("\n");
 594 }
 595
 596
 597 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 598    we should issue an error or a warning, or be quiet.  */
 599
 600 notification
 601 notification_std (int std)
 602 {
 603   int warning;
 604
 605   if (!compile_options.pedantic)
 606     return NOTIFICATION_SILENT;
 607
 608   warning = compile_options.warn_std & std;
 609   if ((compile_options.allow_std & std) != 0 && !warning)
 610     return NOTIFICATION_SILENT;
 611
 612   return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
 613 }
 614
 615
 616 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 617    feature.  An error/warning will be issued if the currently selected
 618    standard does not contain the requested bits.  */
 619
 620 bool
 621 notify_std (st_parameter_common *cmp, int std, const char * message)
 622 {
 623   int warning;
 624
 625   if (!compile_options.pedantic)
 626     return true;
 627
 628   warning = compile_options.warn_std & std;
 629   if ((compile_options.allow_std & std) != 0 && !warning)
 630     return true;
 631
 632   if (!warning)
 633     {
 634       recursion_check ();
 635       show_locus (cmp);
 636       estr_write ("Fortran runtime error: ");
 637       estr_write (message);
 638       estr_write ("\n");
 639       exit (2);
 640     }
 641   else
 642     {
 643       show_locus (cmp);
 644       estr_write ("Fortran runtime warning: ");
 645       estr_write (message);
 646       estr_write ("\n");
 647     }
 648   return false;
 649 }