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 /* show_locus()-- Print a line number and filename describing where
 189  * something went wrong */
 190
 191 void
 192 show_locus (st_parameter_common *cmp)
 193 {
 194   static char *filename;
 195
 196   if (!options.locus || cmp == NULL || cmp->filename == NULL)
 197     return;
 198
 199   if (cmp->unit > 0)
 200     {
 201       filename = filename_from_unit (cmp->unit);
 202       if (filename != NULL)
 203         {
 204           st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
 205                    (int) cmp->line, cmp->filename, cmp->unit, filename);
 206           free_mem (filename);
 207         }
 208       return;
 209     }
 210
 211   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
 212 }
 213
 214
 215 /* recursion_check()-- It's possible for additional errors to occur
 216  * during fatal error processing.  We detect this condition here and
 217  * exit with code 4 immediately. */
 218
 219 #define MAGIC 0x20DE8101
 220
 221 static void
 222 recursion_check (void)
 223 {
 224   static int magic = 0;
 225
 226   /* Don't even try to print something at this point */
 227   if (magic == MAGIC)
 228     sys_exit (4);
 229
 230   magic = MAGIC;
 231 }
 232
 233
 234 /* os_error()-- Operating system error.  We get a message from the
 235  * operating system, show it and leave.  Some operating system errors
 236  * are caught and processed by the library.  If not, we come here. */
 237
 238 void
 239 os_error (const char *message)
 240 {
 241   recursion_check ();
 242   st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
 243   sys_exit (1);
 244 }
 245 iexport(os_error);
 246
 247
 248 /* void runtime_error()-- These are errors associated with an
 249  * invalid fortran program. */
 250
 251 void
 252 runtime_error (const char *message, ...)
 253 {
 254   va_list ap;
 255
 256   recursion_check ();
 257   st_printf ("Fortran runtime error: ");
 258   va_start (ap, message);
 259   st_vprintf (message, ap);
 260   va_end (ap);
 261   st_printf ("\n");
 262   sys_exit (2);
 263 }
 264 iexport(runtime_error);
 265
 266 /* void runtime_error_at()-- These are errors associated with a
 267  * run time error generated by the front end compiler.  */
 268
 269 void
 270 runtime_error_at (const char *where, const char *message)
 271 {
 272   recursion_check ();
 273   st_printf ("%s\n", where);
 274   st_printf ("Fortran runtime error: %s\n", message);
 275   sys_exit (2);
 276 }
 277 iexport(runtime_error_at);
 278
 279
 280 /* void internal_error()-- These are this-can't-happen errors
 281  * that indicate something deeply wrong. */
 282
 283 void
 284 internal_error (st_parameter_common *cmp, const char *message)
 285 {
 286   recursion_check ();
 287   show_locus (cmp);
 288   st_printf ("Internal Error: %s\n", message);
 289
 290   /* This function call is here to get the main.o object file included
 291      when linking statically. This works because error.o is supposed to
 292      be always linked in (and the function call is in internal_error
 293      because hopefully it doesn't happen too often).  */
 294   stupid_function_name_for_static_linking();
 295
 296   sys_exit (3);
 297 }
 298
 299
 300 /* translate_error()-- Given an integer error code, return a string
 301  * describing the error. */
 302
 303 const char *
 304 translate_error (int code)
 305 {
 306   const char *p;
 307
 308   switch (code)
 309     {
 310     case ERROR_EOR:
 311       p = "End of record";
 312       break;
 313
 314     case ERROR_END:
 315       p = "End of file";
 316       break;
 317
 318     case ERROR_OK:
 319       p = "Successful return";
 320       break;
 321
 322     case ERROR_OS:
 323       p = "Operating system error";
 324       break;
 325
 326     case ERROR_BAD_OPTION:
 327       p = "Bad statement option";
 328       break;
 329
 330     case ERROR_MISSING_OPTION:
 331       p = "Missing statement option";
 332       break;
 333
 334     case ERROR_OPTION_CONFLICT:
 335       p = "Conflicting statement options";
 336       break;
 337
 338     case ERROR_ALREADY_OPEN:
 339       p = "File already opened in another unit";
 340       break;
 341
 342     case ERROR_BAD_UNIT:
 343       p = "Unattached unit";
 344       break;
 345
 346     case ERROR_FORMAT:
 347       p = "FORMAT error";
 348       break;
 349
 350     case ERROR_BAD_ACTION:
 351       p = "Incorrect ACTION specified";
 352       break;
 353
 354     case ERROR_ENDFILE:
 355       p = "Read past ENDFILE record";
 356       break;
 357
 358     case ERROR_BAD_US:
 359       p = "Corrupt unformatted sequential file";
 360       break;
 361
 362     case ERROR_READ_VALUE:
 363       p = "Bad value during read";
 364       break;
 365
 366     case ERROR_READ_OVERFLOW:
 367       p = "Numeric overflow on read";
 368       break;
 369
 370     case ERROR_INTERNAL:
 371       p = "Internal error in run-time library";
 372       break;
 373
 374     case ERROR_INTERNAL_UNIT:
 375       p = "Internal unit I/O error";
 376       break;
 377
 378     case ERROR_DIRECT_EOR:
 379       p = "Write exceeds length of DIRECT access record";
 380       break;
 381
 382     case ERROR_SHORT_RECORD:
 383       p = "I/O past end of record on unformatted file";
 384       break;
 385
 386     case ERROR_CORRUPT_FILE:
 387       p = "Unformatted file structure has been corrupted";
 388       break;
 389
 390     default:
 391       p = "Unknown error code";
 392       break;
 393     }
 394
 395   return p;
 396 }
 397
 398
 399 /* generate_error()-- Come here when an error happens.  This
 400  * subroutine is called if it is possible to continue on after the error.
 401  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 402  * ERR labels are present, we return, otherwise we terminate the program
 403  * after printing a message.  The error code is always required but the
 404  * message parameter can be NULL, in which case a string describing
 405  * the most recent operating system error is used. */
 406
 407 void
 408 generate_error (st_parameter_common *cmp, int family, const char *message)
 409 {
 410   /* Set the error status.  */
 411   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 412     *cmp->iostat = (family == ERROR_OS) ? errno : family;
 413
 414   if (message == NULL)
 415     message =
 416       (family == ERROR_OS) ? get_oserror () : translate_error (family);
 417
 418   if (cmp->flags & IOPARM_HAS_IOMSG)
 419     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 420
 421   /* Report status back to the compiler.  */
 422   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 423   switch (family)
 424     {
 425     case ERROR_EOR:
 426       cmp->flags |= IOPARM_LIBRETURN_EOR;
 427       if ((cmp->flags & IOPARM_EOR))
 428         return;
 429       break;
 430
 431     case ERROR_END:
 432       cmp->flags |= IOPARM_LIBRETURN_END;
 433       if ((cmp->flags & IOPARM_END))
 434         return;
 435       break;
 436
 437     default:
 438       cmp->flags |= IOPARM_LIBRETURN_ERROR;
 439       if ((cmp->flags & IOPARM_ERR))
 440         return;
 441       break;
 442     }
 443
 444   /* Return if the user supplied an iostat variable.  */
 445   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 446     return;
 447
 448   /* Terminate the program */
 449
 450   recursion_check ();
 451   show_locus (cmp);
 452   st_printf ("Fortran runtime error: %s\n", message);
 453   sys_exit (2);
 454 }
 455 iexport(generate_error);
 456
 457 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 458    we should issue an error or a warning, or be quiet.  */
 459
 460 notification
 461 notification_std (int std)
 462 {
 463   int warning;
 464
 465   if (!compile_options.pedantic)
 466     return SILENT;
 467
 468   warning = compile_options.warn_std & std;
 469   if ((compile_options.allow_std & std) != 0 && !warning)
 470     return SILENT;
 471
 472   return warning ? WARNING : ERROR;
 473 }
 474
 475
 476
 477 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 478    feature.  An error/warning will be issued if the currently selected
 479    standard does not contain the requested bits.  */
 480
 481 try
 482 notify_std (st_parameter_common *cmp, int std, const char * message)
 483 {
 484   int warning;
 485
 486   if (!compile_options.pedantic)
 487     return SUCCESS;
 488
 489   warning = compile_options.warn_std & std;
 490   if ((compile_options.allow_std & std) != 0 && !warning)
 491     return SUCCESS;
 492
 493   if (!warning)
 494     {
 495       recursion_check ();
 496       show_locus (cmp);
 497       st_printf ("Fortran runtime error: %s\n", message);
 498       sys_exit (2);
 499     }
 500   else
 501     {
 502       show_locus (cmp);
 503       st_printf ("Fortran runtime warning: %s\n", message);
 504     }
 505   return FAILURE;
 506 }