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   va_list ap;
 273
 274   recursion_check ();
 275   st_printf ("%s\n", where);
 276   st_printf ("Fortran runtime error: ");
 277   va_start (ap, message);
 278   st_vprintf (message, ap);
 279   va_end (ap);
 280   st_printf ("\n");
 281   sys_exit (2);
 282 }
 283 iexport(runtime_error_at);
 284
 285
 286 /* void internal_error()-- These are this-can't-happen errors
 287  * that indicate something deeply wrong. */
 288
 289 void
 290 internal_error (st_parameter_common *cmp, const char *message)
 291 {
 292   recursion_check ();
 293   show_locus (cmp);
 294   st_printf ("Internal Error: %s\n", message);
 295
 296   /* This function call is here to get the main.o object file included
 297      when linking statically. This works because error.o is supposed to
 298      be always linked in (and the function call is in internal_error
 299      because hopefully it doesn't happen too often).  */
 300   stupid_function_name_for_static_linking();
 301
 302   sys_exit (3);
 303 }
 304
 305
 306 /* translate_error()-- Given an integer error code, return a string
 307  * describing the error. */
 308
 309 const char *
 310 translate_error (int code)
 311 {
 312   const char *p;
 313
 314   switch (code)
 315     {
 316     case ERROR_EOR:
 317       p = "End of record";
 318       break;
 319
 320     case ERROR_END:
 321       p = "End of file";
 322       break;
 323
 324     case ERROR_OK:
 325       p = "Successful return";
 326       break;
 327
 328     case ERROR_OS:
 329       p = "Operating system error";
 330       break;
 331
 332     case ERROR_BAD_OPTION:
 333       p = "Bad statement option";
 334       break;
 335
 336     case ERROR_MISSING_OPTION:
 337       p = "Missing statement option";
 338       break;
 339
 340     case ERROR_OPTION_CONFLICT:
 341       p = "Conflicting statement options";
 342       break;
 343
 344     case ERROR_ALREADY_OPEN:
 345       p = "File already opened in another unit";
 346       break;
 347
 348     case ERROR_BAD_UNIT:
 349       p = "Unattached unit";
 350       break;
 351
 352     case ERROR_FORMAT:
 353       p = "FORMAT error";
 354       break;
 355
 356     case ERROR_BAD_ACTION:
 357       p = "Incorrect ACTION specified";
 358       break;
 359
 360     case ERROR_ENDFILE:
 361       p = "Read past ENDFILE record";
 362       break;
 363
 364     case ERROR_BAD_US:
 365       p = "Corrupt unformatted sequential file";
 366       break;
 367
 368     case ERROR_READ_VALUE:
 369       p = "Bad value during read";
 370       break;
 371
 372     case ERROR_READ_OVERFLOW:
 373       p = "Numeric overflow on read";
 374       break;
 375
 376     case ERROR_INTERNAL:
 377       p = "Internal error in run-time library";
 378       break;
 379
 380     case ERROR_INTERNAL_UNIT:
 381       p = "Internal unit I/O error";
 382       break;
 383
 384     case ERROR_DIRECT_EOR:
 385       p = "Write exceeds length of DIRECT access record";
 386       break;
 387
 388     case ERROR_SHORT_RECORD:
 389       p = "I/O past end of record on unformatted file";
 390       break;
 391
 392     case ERROR_CORRUPT_FILE:
 393       p = "Unformatted file structure has been corrupted";
 394       break;
 395
 396     default:
 397       p = "Unknown error code";
 398       break;
 399     }
 400
 401   return p;
 402 }
 403
 404
 405 /* generate_error()-- Come here when an error happens.  This
 406  * subroutine is called if it is possible to continue on after the error.
 407  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 408  * ERR labels are present, we return, otherwise we terminate the program
 409  * after printing a message.  The error code is always required but the
 410  * message parameter can be NULL, in which case a string describing
 411  * the most recent operating system error is used. */
 412
 413 void
 414 generate_error (st_parameter_common *cmp, int family, const char *message)
 415 {
 416   /* Set the error status.  */
 417   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 418     *cmp->iostat = (family == ERROR_OS) ? errno : family;
 419
 420   if (message == NULL)
 421     message =
 422       (family == ERROR_OS) ? get_oserror () : translate_error (family);
 423
 424   if (cmp->flags & IOPARM_HAS_IOMSG)
 425     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 426
 427   /* Report status back to the compiler.  */
 428   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 429   switch (family)
 430     {
 431     case ERROR_EOR:
 432       cmp->flags |= IOPARM_LIBRETURN_EOR;
 433       if ((cmp->flags & IOPARM_EOR))
 434         return;
 435       break;
 436
 437     case ERROR_END:
 438       cmp->flags |= IOPARM_LIBRETURN_END;
 439       if ((cmp->flags & IOPARM_END))
 440         return;
 441       break;
 442
 443     default:
 444       cmp->flags |= IOPARM_LIBRETURN_ERROR;
 445       if ((cmp->flags & IOPARM_ERR))
 446         return;
 447       break;
 448     }
 449
 450   /* Return if the user supplied an iostat variable.  */
 451   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 452     return;
 453
 454   /* Terminate the program */
 455
 456   recursion_check ();
 457   show_locus (cmp);
 458   st_printf ("Fortran runtime error: %s\n", message);
 459   sys_exit (2);
 460 }
 461 iexport(generate_error);
 462
 463 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 464    we should issue an error or a warning, or be quiet.  */
 465
 466 notification
 467 notification_std (int std)
 468 {
 469   int warning;
 470
 471   if (!compile_options.pedantic)
 472     return SILENT;
 473
 474   warning = compile_options.warn_std & std;
 475   if ((compile_options.allow_std & std) != 0 && !warning)
 476     return SILENT;
 477
 478   return warning ? WARNING : ERROR;
 479 }
 480
 481
 482
 483 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 484    feature.  An error/warning will be issued if the currently selected
 485    standard does not contain the requested bits.  */
 486
 487 try
 488 notify_std (st_parameter_common *cmp, int std, const char * message)
 489 {
 490   int warning;
 491
 492   if (!compile_options.pedantic)
 493     return SUCCESS;
 494
 495   warning = compile_options.warn_std & std;
 496   if ((compile_options.allow_std & std) != 0 && !warning)
 497     return SUCCESS;
 498
 499   if (!warning)
 500     {
 501       recursion_check ();
 502       show_locus (cmp);
 503       st_printf ("Fortran runtime error: %s\n", message);
 504       sys_exit (2);
 505     }
 506   else
 507     {
 508       show_locus (cmp);
 509       st_printf ("Fortran runtime warning: %s\n", message);
 510     }
 511   return FAILURE;
 512 }