libgfortran/runtime/error.c

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