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