libgfortran/runtime/error.c

   1 /* Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran 95 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 2, or (at your option)
   9 any later version.
  10
  11 In addition to the permissions in the GNU General Public License, the
  12 Free Software Foundation gives you unlimited permission to link the
  13 compiled version of this file into combinations with other programs,
  14 and to distribute those combinations without any restriction coming
  15 from the use of this file.  (The General Public License restrictions
  16 do apply in other respects; for example, they cover modification of
  17 the file, and distribution when not linked into a combine
  18 executable.)
  19
  20 Libgfortran is distributed in the hope that it will be useful,
  21 but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 GNU General Public License for more details.
  24
  25 You should have received a copy of the GNU General Public License
  26 along with libgfortran; see the file COPYING.  If not, write to
  27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  28 Boston, MA 02110-1301, USA.  */
  29
  30
  31 #include "config.h"
  32 #include <assert.h>
  33 #include <stdio.h>
  34 #include <stdarg.h>
  35 #include <string.h>
  36 #include <float.h>
  37 #include <errno.h>
  38
  39 #ifdef HAVE_SIGNAL_H
  40 #include <signal.h>
  41 #endif
  42
  43 #ifdef HAVE_UNISTD_H
  44 #include <unistd.h>
  45 #endif
  46
  47 #ifdef HAVE_STDLIB_H
  48 #include <stdlib.h>
  49 #endif
  50
  51 #ifdef HAVE_SYS_TIME_H
  52 #include <sys/time.h>
  53 #endif
  54
  55 /* <sys/time.h> has to be included before <sys/resource.h> to work
  56    around PR 30518; otherwise, MacOS 10.3.9 headers are just broken.  */
  57 #ifdef HAVE_SYS_RESOURCE_H
  58 #include <sys/resource.h>
  59 #endif
  60
  61 #include "libgfortran.h"
  62
  63 #ifdef __MINGW32__
  64 #define HAVE_GETPID 1
  65 #include <process.h>
  66 #endif
  67
  68
  69 /* sys_exit()-- Terminate the program with an exit code.  */
  70
  71 void
  72 sys_exit (int code)
  73 {
  74   /* Show error backtrace if possible.  */
  75   if (code != 0 && code != 4
  76       && (options.backtrace == 1
  77           || (options.backtrace == -1 && compile_options.backtrace == 1)))
  78     show_backtrace ();
  79
  80   /* Dump core if requested.  */
  81   if (code != 0
  82       && (options.dump_core == 1
  83          || (options.dump_core == -1 && compile_options.dump_core == 1)))
  84     {
  85 #if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
  86       /* Warn if a core file cannot be produced because
  87          of core size limit.  */
  88
  89       struct rlimit core_limit;
  90
  91       if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0)
  92         st_printf ("** Warning: a core dump was requested, but the core size"
  93                    "limit\n**          is currently zero.\n\n");
  94 #endif
  95
  96
  97 #if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
  98       kill (getpid (), SIGQUIT);
  99 #else
 100       st_printf ("Core dump not possible, sorry.");
 101 #endif
 102     }
 103
 104   exit (code);
 105 }
 106
 107
 108 /* Error conditions.  The tricky part here is printing a message when
 109  * it is the I/O subsystem that is severely wounded.  Our goal is to
 110  * try and print something making the fewest assumptions possible,
 111  * then try to clean up before actually exiting.
 112  *
 113  * The following exit conditions are defined:
 114  * 0    Normal program exit.
 115  * 1    Terminated because of operating system error.
 116  * 2    Error in the runtime library
 117  * 3    Internal error in runtime library
 118  * 4    Error during error processing (very bad)
 119  *
 120  * Other error returns are reserved for the STOP statement with a numeric code.
 121  */
 122
 123 /* gfc_itoa()-- Integer to decimal conversion. */
 124
 125 const char *
 126 gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
 127 {
 128   int negative;
 129   char *p;
 130   GFC_UINTEGER_LARGEST t;
 131
 132   assert (len >= GFC_ITOA_BUF_SIZE);
 133
 134   if (n == 0)
 135     return "0";
 136
 137   negative = 0;
 138   t = n;
 139   if (n < 0)
 140     {
 141       negative = 1;
 142       t = -n; /*must use unsigned to protect from overflow*/
 143     }
 144
 145   p = buffer + GFC_ITOA_BUF_SIZE - 1;
 146   *p = '\0';
 147
 148   while (t != 0)
 149     {
 150       *--p = '0' + (t % 10);
 151       t /= 10;
 152     }
 153
 154   if (negative)
 155     *--p = '-';
 156   return p;
 157 }
 158
 159
 160 /* xtoa()-- Integer to hexadecimal conversion.  */
 161
 162 const char *
 163 xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 164 {
 165   int digit;
 166   char *p;
 167
 168   assert (len >= GFC_XTOA_BUF_SIZE);
 169
 170   if (n == 0)
 171     return "0";
 172
 173   p = buffer + GFC_XTOA_BUF_SIZE - 1;
 174   *p = '\0';
 175
 176   while (n != 0)
 177     {
 178       digit = n & 0xF;
 179       if (digit > 9)
 180         digit += 'A' - '0' - 10;
 181
 182       *--p = '0' + digit;
 183       n >>= 4;
 184     }
 185
 186   return p;
 187 }
 188
 189
 190 /* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
 191
 192 void
 193 st_sprintf (char *buffer, const char *format, ...)
 194 {
 195   va_list arg;
 196   char c;
 197   const char *p;
 198   int count;
 199   char itoa_buf[GFC_ITOA_BUF_SIZE];
 200
 201   va_start (arg, format);
 202
 203   for (;;)
 204     {
 205       c = *format++;
 206       if (c != '%')
 207         {
 208           *buffer++ = c;
 209           if (c == '\0')
 210             break;
 211           continue;
 212         }
 213
 214       c = *format++;
 215       switch (c)
 216         {
 217         case 'c':
 218           *buffer++ = (char) va_arg (arg, int);
 219           break;
 220
 221         case 'd':
 222           p = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf));
 223           count = strlen (p);
 224
 225           memcpy (buffer, p, count);
 226           buffer += count;
 227           break;
 228
 229         case 's':
 230           p = va_arg (arg, char *);
 231           count = strlen (p);
 232
 233           memcpy (buffer, p, count);
 234           buffer += count;
 235           break;
 236
 237         default:
 238           *buffer++ = c;
 239         }
 240     }
 241
 242   va_end (arg);
 243 }
 244
 245
 246 /* show_locus()-- Print a line number and filename describing where
 247  * something went wrong */
 248
 249 void
 250 show_locus (st_parameter_common *cmp)
 251 {
 252   if (!options.locus || cmp == NULL || cmp->filename == NULL)
 253     return;
 254
 255   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
 256 }
 257
 258
 259 /* recursion_check()-- It's possible for additional errors to occur
 260  * during fatal error processing.  We detect this condition here and
 261  * exit with code 4 immediately. */
 262
 263 #define MAGIC 0x20DE8101
 264
 265 static void
 266 recursion_check (void)
 267 {
 268   static int magic = 0;
 269
 270   /* Don't even try to print something at this point */
 271   if (magic == MAGIC)
 272     sys_exit (4);
 273
 274   magic = MAGIC;
 275 }
 276
 277
 278 /* os_error()-- Operating system error.  We get a message from the
 279  * operating system, show it and leave.  Some operating system errors
 280  * are caught and processed by the library.  If not, we come here. */
 281
 282 void
 283 os_error (const char *message)
 284 {
 285   recursion_check ();
 286   st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
 287   sys_exit (1);
 288 }
 289
 290
 291 /* void runtime_error()-- These are errors associated with an
 292  * invalid fortran program. */
 293
 294 void
 295 runtime_error (const char *message)
 296 {
 297   recursion_check ();
 298   st_printf ("Fortran runtime error: %s\n", message);
 299   sys_exit (2);
 300 }
 301 iexport(runtime_error);
 302
 303
 304 /* void internal_error()-- These are this-can't-happen errors
 305  * that indicate something deeply wrong. */
 306
 307 void
 308 internal_error (st_parameter_common *cmp, const char *message)
 309 {
 310   recursion_check ();
 311   show_locus (cmp);
 312   st_printf ("Internal Error: %s\n", message);
 313
 314   /* This function call is here to get the main.o object file included
 315      when linking statically. This works because error.o is supposed to
 316      be always linked in (and the function call is in internal_error
 317      because hopefully it doesn't happen too often).  */
 318   stupid_function_name_for_static_linking();
 319
 320   sys_exit (3);
 321 }
 322
 323
 324 /* translate_error()-- Given an integer error code, return a string
 325  * describing the error. */
 326
 327 const char *
 328 translate_error (int code)
 329 {
 330   const char *p;
 331
 332   switch (code)
 333     {
 334     case ERROR_EOR:
 335       p = "End of record";
 336       break;
 337
 338     case ERROR_END:
 339       p = "End of file";
 340       break;
 341
 342     case ERROR_OK:
 343       p = "Successful return";
 344       break;
 345
 346     case ERROR_OS:
 347       p = "Operating system error";
 348       break;
 349
 350     case ERROR_BAD_OPTION:
 351       p = "Bad statement option";
 352       break;
 353
 354     case ERROR_MISSING_OPTION:
 355       p = "Missing statement option";
 356       break;
 357
 358     case ERROR_OPTION_CONFLICT:
 359       p = "Conflicting statement options";
 360       break;
 361
 362     case ERROR_ALREADY_OPEN:
 363       p = "File already opened in another unit";
 364       break;
 365
 366     case ERROR_BAD_UNIT:
 367       p = "Unattached unit";
 368       break;
 369
 370     case ERROR_FORMAT:
 371       p = "FORMAT error";
 372       break;
 373
 374     case ERROR_BAD_ACTION:
 375       p = "Incorrect ACTION specified";
 376       break;
 377
 378     case ERROR_ENDFILE:
 379       p = "Read past ENDFILE record";
 380       break;
 381
 382     case ERROR_BAD_US:
 383       p = "Corrupt unformatted sequential file";
 384       break;
 385
 386     case ERROR_READ_VALUE:
 387       p = "Bad value during read";
 388       break;
 389
 390     case ERROR_READ_OVERFLOW:
 391       p = "Numeric overflow on read";
 392       break;
 393
 394     case ERROR_INTERNAL:
 395       p = "Internal error in run-time library";
 396       break;
 397
 398     case ERROR_INTERNAL_UNIT:
 399       p = "Internal unit I/O error";
 400       break;
 401
 402     case ERROR_DIRECT_EOR:
 403       p = "Write exceeds length of DIRECT access record";
 404       break;
 405
 406     case ERROR_SHORT_RECORD:
 407       p = "I/O past end of record on unformatted file";
 408       break;
 409
 410     case ERROR_CORRUPT_FILE:
 411       p = "Unformatted file structure has been corrupted";
 412       break;
 413
 414     default:
 415       p = "Unknown error code";
 416       break;
 417     }
 418
 419   return p;
 420 }
 421
 422
 423 /* generate_error()-- Come here when an error happens.  This
 424  * subroutine is called if it is possible to continue on after the error.
 425  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 426  * ERR labels are present, we return, otherwise we terminate the program
 427  * after printing a message.  The error code is always required but the
 428  * message parameter can be NULL, in which case a string describing
 429  * the most recent operating system error is used. */
 430
 431 void
 432 generate_error (st_parameter_common *cmp, int family, const char *message)
 433 {
 434   /* Set the error status.  */
 435   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 436     *cmp->iostat = (family == ERROR_OS) ? errno : family;
 437
 438   if (message == NULL)
 439     message =
 440       (family == ERROR_OS) ? get_oserror () : translate_error (family);
 441
 442   if (cmp->flags & IOPARM_HAS_IOMSG)
 443     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 444
 445   /* Report status back to the compiler.  */
 446   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 447   switch (family)
 448     {
 449     case ERROR_EOR:
 450       cmp->flags |= IOPARM_LIBRETURN_EOR;
 451       if ((cmp->flags & IOPARM_EOR))
 452         return;
 453       break;
 454
 455     case ERROR_END:
 456       cmp->flags |= IOPARM_LIBRETURN_END;
 457       if ((cmp->flags & IOPARM_END))
 458         return;
 459       break;
 460
 461     default:
 462       cmp->flags |= IOPARM_LIBRETURN_ERROR;
 463       if ((cmp->flags & IOPARM_ERR))
 464         return;
 465       break;
 466     }
 467
 468   /* Return if the user supplied an iostat variable.  */
 469   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 470     return;
 471
 472   /* Terminate the program */
 473
 474   recursion_check ();
 475   show_locus (cmp);
 476   st_printf ("Fortran runtime error: %s\n", message);
 477   sys_exit (2);
 478 }
 479
 480
 481 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 482    we should issue an error or a warning, or be quiet.  */
 483
 484 notification
 485 notification_std (int std)
 486 {
 487   int warning;
 488
 489   if (!compile_options.pedantic)
 490     return SILENT;
 491
 492   warning = compile_options.warn_std & std;
 493   if ((compile_options.allow_std & std) != 0 && !warning)
 494     return SILENT;
 495
 496   return warning ? WARNING : ERROR;
 497 }
 498
 499
 500
 501 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 502    feature.  An error/warning will be issued if the currently selected
 503    standard does not contain the requested bits.  */
 504
 505 try
 506 notify_std (st_parameter_common *cmp, int std, const char * message)
 507 {
 508   int warning;
 509
 510   if (!compile_options.pedantic)
 511     return SUCCESS;
 512
 513   warning = compile_options.warn_std & std;
 514   if ((compile_options.allow_std & std) != 0 && !warning)
 515     return SUCCESS;
 516
 517   if (!warning)
 518     {
 519       recursion_check ();
 520       show_locus (cmp);
 521       st_printf ("Fortran runtime error: %s\n", message);
 522       sys_exit (2);
 523     }
 524   else
 525     {
 526       show_locus (cmp);
 527       st_printf ("Fortran runtime warning: %s\n", message);
 528     }
 529   return FAILURE;
 530 }