libgfortran/runtime/error.c

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