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 /* sys_exit()-- Terminate the program with an exit code.  */
  62
  63 void
  64 sys_exit (int code)
  65 {
  66   /* Show error backtrace if possible.  */
  67   if (code != 0 && code != 4
  68       && (options.backtrace == 1
  69           || (options.backtrace == -1 && compile_options.backtrace == 1)))
  70     show_backtrace ();
  71
  72   /* Dump core if requested.  */
  73   if (code != 0
  74       && (options.dump_core == 1
  75          || (options.dump_core == -1 && compile_options.dump_core == 1)))
  76     {
  77 #if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
  78       /* Warn if a core file cannot be produced because
  79          of core size limit.  */
  80
  81       struct rlimit core_limit;
  82
  83       if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0)
  84         estr_write ("** Warning: a core dump was requested, but the core size"
  85                    "limit\n**          is currently zero.\n\n");
  86 #endif
  87
  88
  89 #if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
  90       kill (getpid (), SIGQUIT);
  91 #else
  92       estr_write ("Core dump not possible, sorry.");
  93 #endif
  94     }
  95
  96   exit (code);
  97 }
  98
  99
 100 /* Error conditions.  The tricky part here is printing a message when
 101  * it is the I/O subsystem that is severely wounded.  Our goal is to
 102  * try and print something making the fewest assumptions possible,
 103  * then try to clean up before actually exiting.
 104  *
 105  * The following exit conditions are defined:
 106  * 0    Normal program exit.
 107  * 1    Terminated because of operating system error.
 108  * 2    Error in the runtime library
 109  * 3    Internal error in runtime library
 110  * 4    Error during error processing (very bad)
 111  *
 112  * Other error returns are reserved for the STOP statement with a numeric code.
 113  */
 114
 115
 116 /* Write a null-terminated C string to standard error. This function
 117    is async-signal-safe.  */
 118
 119 ssize_t
 120 estr_write (const char *str)
 121 {
 122   return write (STDERR_FILENO, str, strlen (str));
 123 }
 124
 125
 126 /* st_vprintf()-- vsnprintf-like function for error output.  We use a
 127    stack allocated buffer for formatting; since this function might be
 128    called from within a signal handler, printing directly to stderr
 129    with vfprintf is not safe since the stderr locking might lead to a
 130    deadlock.  */
 131
 132 #define ST_VPRINTF_SIZE 512
 133
 134 int
 135 st_vprintf (const char *format, va_list ap)
 136 {
 137   int written;
 138   char buffer[ST_VPRINTF_SIZE];
 139
 140 #ifdef HAVE_VSNPRINTF
 141   written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
 142 #else
 143   written = vsprintf(buffer, format, ap);
 144
 145   if (written >= ST_VPRINTF_SIZE - 1)
 146     {
 147       /* The error message was longer than our buffer.  Ouch.  Because
 148          we may have messed up things badly, report the error and
 149          quit.  */
 150 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
 151       write (STDERR_FILENO, buffer, ST_VPRINTF_SIZE - 1);
 152       write (STDERR_FILENO, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
 153       sys_exit(2);
 154 #undef ERROR_MESSAGE
 155
 156     }
 157 #endif
 158
 159   written = write (STDERR_FILENO, buffer, written);
 160   return written;
 161 }
 162
 163
 164 int
 165 st_printf (const char * format, ...)
 166 {
 167   int written;
 168   va_list ap;
 169   va_start (ap, format);
 170   written = st_vprintf (format, ap);
 171   va_end (ap);
 172   return written;
 173 }
 174
 175
 176 /* gfc_xtoa()-- Integer to hexadecimal conversion.  */
 177
 178 const char *
 179 gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 180 {
 181   int digit;
 182   char *p;
 183
 184   assert (len >= GFC_XTOA_BUF_SIZE);
 185
 186   if (n == 0)
 187     return "0";
 188
 189   p = buffer + GFC_XTOA_BUF_SIZE - 1;
 190   *p = '\0';
 191
 192   while (n != 0)
 193     {
 194       digit = n & 0xF;
 195       if (digit > 9)
 196         digit += 'A' - '0' - 10;
 197
 198       *--p = '0' + digit;
 199       n >>= 4;
 200     }
 201
 202   return p;
 203 }
 204
 205
 206 /* Hopefully thread-safe wrapper for a strerror_r() style function.  */
 207
 208 char *
 209 gf_strerror (int errnum,
 210              char * buf __attribute__((unused)),
 211              size_t buflen __attribute__((unused)))
 212 {
 213 #ifdef HAVE_STRERROR_R
 214   /* TODO: How to prevent the compiler warning due to strerror_r of
 215      the untaken branch having the wrong return type?  */
 216   if (__builtin_classify_type (strerror_r (0, buf, 0)) == 5)
 217     {
 218       /* GNU strerror_r()  */
 219       return strerror_r (errnum, buf, buflen);
 220     }
 221   else
 222     {
 223       /* POSIX strerror_r ()  */
 224       strerror_r (errnum, buf, buflen);
 225       return buf;
 226     }
 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_exit (4);
 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   sys_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   sys_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   sys_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   sys_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   sys_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       sys_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 }