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