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