libgfortran/runtime/error.c

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