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       else
 206         {
 207           st_printf ("At line %d of file %s (unit = %d)\n",
 208                    (int) cmp->line, cmp->filename, cmp->unit);
 209         }
 210       return;
 211     }
 212
 213   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
 214 }
 215
 216
 217 /* recursion_check()-- It's possible for additional errors to occur
 218  * during fatal error processing.  We detect this condition here and
 219  * exit with code 4 immediately. */
 220
 221 #define MAGIC 0x20DE8101
 222
 223 static void
 224 recursion_check (void)
 225 {
 226   static int magic = 0;
 227
 228   /* Don't even try to print something at this point */
 229   if (magic == MAGIC)
 230     sys_exit (4);
 231
 232   magic = MAGIC;
 233 }
 234
 235
 236 /* os_error()-- Operating system error.  We get a message from the
 237  * operating system, show it and leave.  Some operating system errors
 238  * are caught and processed by the library.  If not, we come here. */
 239
 240 void
 241 os_error (const char *message)
 242 {
 243   recursion_check ();
 244   st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
 245   sys_exit (1);
 246 }
 247 iexport(os_error);
 248
 249
 250 /* void runtime_error()-- These are errors associated with an
 251  * invalid fortran program. */
 252
 253 void
 254 runtime_error (const char *message, ...)
 255 {
 256   va_list ap;
 257
 258   recursion_check ();
 259   st_printf ("Fortran runtime error: ");
 260   va_start (ap, message);
 261   st_vprintf (message, ap);
 262   va_end (ap);
 263   st_printf ("\n");
 264   sys_exit (2);
 265 }
 266 iexport(runtime_error);
 267
 268 /* void runtime_error_at()-- These are errors associated with a
 269  * run time error generated by the front end compiler.  */
 270
 271 void
 272 runtime_error_at (const char *where, const char *message, ...)
 273 {
 274   va_list ap;
 275
 276   recursion_check ();
 277   st_printf ("%s\n", where);
 278   st_printf ("Fortran runtime error: ");
 279   va_start (ap, message);
 280   st_vprintf (message, ap);
 281   va_end (ap);
 282   st_printf ("\n");
 283   sys_exit (2);
 284 }
 285 iexport(runtime_error_at);
 286
 287
 288 void
 289 runtime_warning_at (const char *where, const char *message, ...)
 290 {
 291   va_list ap;
 292
 293   st_printf ("%s\n", where);
 294   st_printf ("Fortran runtime warning: ");
 295   va_start (ap, message);
 296   st_vprintf (message, ap);
 297   va_end (ap);
 298   st_printf ("\n");
 299 }
 300 iexport(runtime_warning_at);
 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 LIBERROR_EOR:
 334       p = "End of record";
 335       break;
 336
 337     case LIBERROR_END:
 338       p = "End of file";
 339       break;
 340
 341     case LIBERROR_OK:
 342       p = "Successful return";
 343       break;
 344
 345     case LIBERROR_OS:
 346       p = "Operating system error";
 347       break;
 348
 349     case LIBERROR_BAD_OPTION:
 350       p = "Bad statement option";
 351       break;
 352
 353     case LIBERROR_MISSING_OPTION:
 354       p = "Missing statement option";
 355       break;
 356
 357     case LIBERROR_OPTION_CONFLICT:
 358       p = "Conflicting statement options";
 359       break;
 360
 361     case LIBERROR_ALREADY_OPEN:
 362       p = "File already opened in another unit";
 363       break;
 364
 365     case LIBERROR_BAD_UNIT:
 366       p = "Unattached unit";
 367       break;
 368
 369     case LIBERROR_FORMAT:
 370       p = "FORMAT error";
 371       break;
 372
 373     case LIBERROR_BAD_ACTION:
 374       p = "Incorrect ACTION specified";
 375       break;
 376
 377     case LIBERROR_ENDFILE:
 378       p = "Read past ENDFILE record";
 379       break;
 380
 381     case LIBERROR_BAD_US:
 382       p = "Corrupt unformatted sequential file";
 383       break;
 384
 385     case LIBERROR_READ_VALUE:
 386       p = "Bad value during read";
 387       break;
 388
 389     case LIBERROR_READ_OVERFLOW:
 390       p = "Numeric overflow on read";
 391       break;
 392
 393     case LIBERROR_INTERNAL:
 394       p = "Internal error in run-time library";
 395       break;
 396
 397     case LIBERROR_INTERNAL_UNIT:
 398       p = "Internal unit I/O error";
 399       break;
 400
 401     case LIBERROR_DIRECT_EOR:
 402       p = "Write exceeds length of DIRECT access record";
 403       break;
 404
 405     case LIBERROR_SHORT_RECORD:
 406       p = "I/O past end of record on unformatted file";
 407       break;
 408
 409     case LIBERROR_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
 434   /* If there was a previous error, don't mask it with another
 435      error message, EOF or EOR condition.  */
 436
 437   if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
 438     return;
 439
 440   /* Set the error status.  */
 441   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 442     *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
 443
 444   if (message == NULL)
 445     message =
 446       (family == LIBERROR_OS) ? get_oserror () : translate_error (family);
 447
 448   if (cmp->flags & IOPARM_HAS_IOMSG)
 449     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 450
 451   /* Report status back to the compiler.  */
 452   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 453   switch (family)
 454     {
 455     case LIBERROR_EOR:
 456       cmp->flags |= IOPARM_LIBRETURN_EOR;
 457       if ((cmp->flags & IOPARM_EOR))
 458         return;
 459       break;
 460
 461     case LIBERROR_END:
 462       cmp->flags |= IOPARM_LIBRETURN_END;
 463       if ((cmp->flags & IOPARM_END))
 464         return;
 465       break;
 466
 467     default:
 468       cmp->flags |= IOPARM_LIBRETURN_ERROR;
 469       if ((cmp->flags & IOPARM_ERR))
 470         return;
 471       break;
 472     }
 473
 474   /* Return if the user supplied an iostat variable.  */
 475   if ((cmp->flags & IOPARM_HAS_IOSTAT))
 476     return;
 477
 478   /* Terminate the program */
 479
 480   recursion_check ();
 481   show_locus (cmp);
 482   st_printf ("Fortran runtime error: %s\n", message);
 483   sys_exit (2);
 484 }
 485 iexport(generate_error);
 486
 487 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 488    we should issue an error or a warning, or be quiet.  */
 489
 490 notification
 491 notification_std (int std)
 492 {
 493   int warning;
 494
 495   if (!compile_options.pedantic)
 496     return SILENT;
 497
 498   warning = compile_options.warn_std & std;
 499   if ((compile_options.allow_std & std) != 0 && !warning)
 500     return SILENT;
 501
 502   return warning ? WARNING : ERROR;
 503 }
 504
 505
 506
 507 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 508    feature.  An error/warning will be issued if the currently selected
 509    standard does not contain the requested bits.  */
 510
 511 try
 512 notify_std (st_parameter_common *cmp, int std, const char * message)
 513 {
 514   int warning;
 515
 516   if (!compile_options.pedantic)
 517     return SUCCESS;
 518
 519   warning = compile_options.warn_std & std;
 520   if ((compile_options.allow_std & std) != 0 && !warning)
 521     return SUCCESS;
 522
 523   if (!warning)
 524     {
 525       recursion_check ();
 526       show_locus (cmp);
 527       st_printf ("Fortran runtime error: %s\n", message);
 528       sys_exit (2);
 529     }
 530   else
 531     {
 532       show_locus (cmp);
 533       st_printf ("Fortran runtime warning: %s\n", message);
 534     }
 535   return FAILURE;
 536 }