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