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