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