libgfortran/runtime/error.c

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