libgfortran/runtime/error.c

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