libgfortran/runtime/error.c

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