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         st_printf ("** 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       st_printf ("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 /* gfc_xtoa()-- Integer to hexadecimal conversion.  */
 116
 117 const char *
 118 gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 119 {
 120   int digit;
 121   char *p;
 122
 123   assert (len >= GFC_XTOA_BUF_SIZE);
 124
 125   if (n == 0)
 126     return "0";
 127
 128   p = buffer + GFC_XTOA_BUF_SIZE - 1;
 129   *p = '\0';
 130
 131   while (n != 0)
 132     {
 133       digit = n & 0xF;
 134       if (digit > 9)
 135         digit += 'A' - '0' - 10;
 136
 137       *--p = '0' + digit;
 138       n >>= 4;
 139     }
 140
 141   return p;
 142 }
 143
 144
 145 /* Hopefully thread-safe wrapper for a strerror_r() style function.  */
 146
 147 char *
 148 gf_strerror (int errnum,
 149              char * buf __attribute__((unused)),
 150              size_t buflen __attribute__((unused)))
 151 {
 152 #ifdef HAVE_STRERROR_R
 153   /* TODO: How to prevent the compiler warning due to strerror_r of
 154      the untaken branch having the wrong return type?  */
 155   if (__builtin_classify_type (strerror_r (0, buf, 0)) == 5)
 156     {
 157       /* GNU strerror_r()  */
 158       return strerror_r (errnum, buf, buflen);
 159     }
 160   else
 161     {
 162       /* POSIX strerror_r ()  */
 163       strerror_r (errnum, buf, buflen);
 164       return buf;
 165     }
 166 #else
 167   /* strerror () is not necessarily thread-safe, but should at least
 168      be available everywhere.  */
 169   return strerror (errnum);
 170 #endif
 171 }
 172
 173
 174 /* show_locus()-- Print a line number and filename describing where
 175  * something went wrong */
 176
 177 void
 178 show_locus (st_parameter_common *cmp)
 179 {
 180   static char *filename;
 181
 182   if (!options.locus || cmp == NULL || cmp->filename == NULL)
 183     return;
 184
 185   if (cmp->unit > 0)
 186     {
 187       filename = filename_from_unit (cmp->unit);
 188       if (filename != NULL)
 189         {
 190           st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
 191                    (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
 192           free (filename);
 193         }
 194       else
 195         {
 196           st_printf ("At line %d of file %s (unit = %d)\n",
 197                    (int) cmp->line, cmp->filename, (int) cmp->unit);
 198         }
 199       return;
 200     }
 201
 202   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
 203 }
 204
 205
 206 /* recursion_check()-- It's possible for additional errors to occur
 207  * during fatal error processing.  We detect this condition here and
 208  * exit with code 4 immediately. */
 209
 210 #define MAGIC 0x20DE8101
 211
 212 static void
 213 recursion_check (void)
 214 {
 215   static int magic = 0;
 216
 217   /* Don't even try to print something at this point */
 218   if (magic == MAGIC)
 219     sys_exit (4);
 220
 221   magic = MAGIC;
 222 }
 223
 224
 225 #define STRERR_MAXSZ 256
 226
 227 /* os_error()-- Operating system error.  We get a message from the
 228  * operating system, show it and leave.  Some operating system errors
 229  * are caught and processed by the library.  If not, we come here. */
 230
 231 void
 232 os_error (const char *message)
 233 {
 234   char errmsg[STRERR_MAXSZ];
 235   recursion_check ();
 236   st_printf ("Operating system error: %s\n%s\n",
 237              gf_strerror (errno, errmsg, STRERR_MAXSZ), message);
 238   sys_exit (1);
 239 }
 240 iexport(os_error);
 241
 242
 243 /* void runtime_error()-- These are errors associated with an
 244  * invalid fortran program. */
 245
 246 void
 247 runtime_error (const char *message, ...)
 248 {
 249   va_list ap;
 250
 251   recursion_check ();
 252   st_printf ("Fortran runtime error: ");
 253   va_start (ap, message);
 254   st_vprintf (message, ap);
 255   va_end (ap);
 256   st_printf ("\n");
 257   sys_exit (2);
 258 }
 259 iexport(runtime_error);
 260
 261 /* void runtime_error_at()-- These are errors associated with a
 262  * run time error generated by the front end compiler.  */
 263
 264 void
 265 runtime_error_at (const char *where, const char *message, ...)
 266 {
 267   va_list ap;
 268
 269   recursion_check ();
 270   st_printf ("%s\n", where);
 271   st_printf ("Fortran runtime error: ");
 272   va_start (ap, message);
 273   st_vprintf (message, ap);
 274   va_end (ap);
 275   st_printf ("\n");
 276   sys_exit (2);
 277 }
 278 iexport(runtime_error_at);
 279
 280
 281 void
 282 runtime_warning_at (const char *where, const char *message, ...)
 283 {
 284   va_list ap;
 285
 286   st_printf ("%s\n", where);
 287   st_printf ("Fortran runtime warning: ");
 288   va_start (ap, message);
 289   st_vprintf (message, ap);
 290   va_end (ap);
 291   st_printf ("\n");
 292 }
 293 iexport(runtime_warning_at);
 294
 295
 296 /* void internal_error()-- These are this-can't-happen errors
 297  * that indicate something deeply wrong. */
 298
 299 void
 300 internal_error (st_parameter_common *cmp, const char *message)
 301 {
 302   recursion_check ();
 303   show_locus (cmp);
 304   st_printf ("Internal Error: %s\n", message);
 305
 306   /* This function call is here to get the main.o object file included
 307      when linking statically. This works because error.o is supposed to
 308      be always linked in (and the function call is in internal_error
 309      because hopefully it doesn't happen too often).  */
 310   stupid_function_name_for_static_linking();
 311
 312   sys_exit (3);
 313 }
 314
 315
 316 /* translate_error()-- Given an integer error code, return a string
 317  * describing the error. */
 318
 319 const char *
 320 translate_error (int code)
 321 {
 322   const char *p;
 323
 324   switch (code)
 325     {
 326     case LIBERROR_EOR:
 327       p = "End of record";
 328       break;
 329
 330     case LIBERROR_END:
 331       p = "End of file";
 332       break;
 333
 334     case LIBERROR_OK:
 335       p = "Successful return";
 336       break;
 337
 338     case LIBERROR_OS:
 339       p = "Operating system error";
 340       break;
 341
 342     case LIBERROR_BAD_OPTION:
 343       p = "Bad statement option";
 344       break;
 345
 346     case LIBERROR_MISSING_OPTION:
 347       p = "Missing statement option";
 348       break;
 349
 350     case LIBERROR_OPTION_CONFLICT:
 351       p = "Conflicting statement options";
 352       break;
 353
 354     case LIBERROR_ALREADY_OPEN:
 355       p = "File already opened in another unit";
 356       break;
 357
 358     case LIBERROR_BAD_UNIT:
 359       p = "Unattached unit";
 360       break;
 361
 362     case LIBERROR_FORMAT:
 363       p = "FORMAT error";
 364       break;
 365
 366     case LIBERROR_BAD_ACTION:
 367       p = "Incorrect ACTION specified";
 368       break;
 369
 370     case LIBERROR_ENDFILE:
 371       p = "Read past ENDFILE record";
 372       break;
 373
 374     case LIBERROR_BAD_US:
 375       p = "Corrupt unformatted sequential file";
 376       break;
 377
 378     case LIBERROR_READ_VALUE:
 379       p = "Bad value during read";
 380       break;
 381
 382     case LIBERROR_READ_OVERFLOW:
 383       p = "Numeric overflow on read";
 384       break;
 385
 386     case LIBERROR_INTERNAL:
 387       p = "Internal error in run-time library";
 388       break;
 389
 390     case LIBERROR_INTERNAL_UNIT:
 391       p = "Internal unit I/O error";
 392       break;
 393
 394     case LIBERROR_DIRECT_EOR:
 395       p = "Write exceeds length of DIRECT access record";
 396       break;
 397
 398     case LIBERROR_SHORT_RECORD:
 399       p = "I/O past end of record on unformatted file";
 400       break;
 401
 402     case LIBERROR_CORRUPT_FILE:
 403       p = "Unformatted file structure has been corrupted";
 404       break;
 405
 406     default:
 407       p = "Unknown error code";
 408       break;
 409     }
 410
 411   return p;
 412 }
 413
 414
 415 /* generate_error()-- Come here when an error happens.  This
 416  * subroutine is called if it is possible to continue on after the error.
 417  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 418  * ERR labels are present, we return, otherwise we terminate the program
 419  * after printing a message.  The error code is always required but the
 420  * message parameter can be NULL, in which case a string describing
 421  * the most recent operating system error is used. */
 422
 423 void
 424 generate_error (st_parameter_common *cmp, int family, const char *message)
 425 {
 426   char errmsg[STRERR_MAXSZ];
 427
 428   /* If there was a previous error, don't mask it with another
 429      error message, EOF or EOR condition.  */
 430
 431   if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
 432     return;
 433
 434   /* Set the error status.  */
 435   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 436     *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
 437
 438   if (message == NULL)
 439     message =
 440       (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
 441       translate_error (family);
 442
 443   if (cmp->flags & IOPARM_HAS_IOMSG)
 444     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 445
 446   /* Report status back to the compiler.  */
 447   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 448   switch (family)
 449     {
 450     case LIBERROR_EOR:
 451       cmp->flags |= IOPARM_LIBRETURN_EOR;
 452       if ((cmp->flags & IOPARM_EOR))
 453         return;
 454       break;
 455
 456     case LIBERROR_END:
 457       cmp->flags |= IOPARM_LIBRETURN_END;
 458       if ((cmp->flags & IOPARM_END))
 459         return;
 460       break;
 461
 462     default:
 463       cmp->flags |= IOPARM_LIBRETURN_ERROR;
 464       if ((cmp->flags & IOPARM_ERR))
 465         return;
 466       break;
 467     }
 468
 469   /* Return if the user supplied an iostat variable.  */
 470   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 471     return;
 472
 473   /* Terminate the program */
 474
 475   recursion_check ();
 476   show_locus (cmp);
 477   st_printf ("Fortran runtime error: %s\n", message);
 478   sys_exit (2);
 479 }
 480 iexport(generate_error);
 481
 482
 483 /* generate_warning()-- Similar to generate_error but just give a warning.  */
 484
 485 void
 486 generate_warning (st_parameter_common *cmp, const char *message)
 487 {
 488   if (message == NULL)
 489     message = " ";
 490
 491   show_locus (cmp);
 492   st_printf ("Fortran runtime warning: %s\n", message);
 493 }
 494
 495
 496 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 497    we should issue an error or a warning, or be quiet.  */
 498
 499 notification
 500 notification_std (int std)
 501 {
 502   int warning;
 503
 504   if (!compile_options.pedantic)
 505     return NOTIFICATION_SILENT;
 506
 507   warning = compile_options.warn_std & std;
 508   if ((compile_options.allow_std & std) != 0 && !warning)
 509     return NOTIFICATION_SILENT;
 510
 511   return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
 512 }
 513
 514
 515 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 516    feature.  An error/warning will be issued if the currently selected
 517    standard does not contain the requested bits.  */
 518
 519 try
 520 notify_std (st_parameter_common *cmp, int std, const char * message)
 521 {
 522   int warning;
 523
 524   if (!compile_options.pedantic)
 525     return SUCCESS;
 526
 527   warning = compile_options.warn_std & std;
 528   if ((compile_options.allow_std & std) != 0 && !warning)
 529     return SUCCESS;
 530
 531   if (!warning)
 532     {
 533       recursion_check ();
 534       show_locus (cmp);
 535       st_printf ("Fortran runtime error: %s\n", message);
 536       sys_exit (2);
 537     }
 538   else
 539     {
 540       show_locus (cmp);
 541       st_printf ("Fortran runtime warning: %s\n", message);
 542     }
 543   return FAILURE;
 544 }