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