libgfortran/runtime/error.c

   1 /* Copyright (C) 2002-2003 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran 95 runtime library (libgfor).
   5
   6 Libgfor 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 Libgfor is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with libgfor; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21
  22 #include "config.h"
  23 #include <stdio.h>
  24 #include <stdarg.h>
  25 #include <string.h>
  26 #include <float.h>
  27
  28 #include "libgfortran.h"
  29 #include "../io/io.h"
  30
  31 /* Error conditions.  The tricky part here is printing a message when
  32  * it is the I/O subsystem that is severely wounded.  Our goal is to
  33  * try and print something making the fewest assumptions possible,
  34  * then try to clean up before actually exiting.
  35  *
  36  * The following exit conditions are defined:
  37  * 0    Normal program exit.
  38  * 1    Terminated because of operating system error.
  39  * 2    Error in the runtime library
  40  * 3    Internal error in runtime library
  41  * 4    Error during error processing (very bad)
  42  *
  43  * Other error returns are reserved for the STOP statement with a numeric code.
  44  */
  45
  46 /* locus variables.  These are optionally set by a caller before a
  47  * library subroutine is called.  They are always cleared on exit so
  48  * that files that report loci and those that do not can be linked
  49  * together without reporting an erroneous position. */
  50
  51 char *filename;
  52 unsigned line;
  53
  54 static char buffer[32];         /* buffer for integer/ascii conversions */
  55
  56 /* rtoa()-- Real to ascii conversion for base 10 and below.
  57  * Returns a pointer to a static buffer.  */
  58
  59 char *
  60 rtoa (double f, int length, int oprec)
  61 {
  62   double n = f;
  63   double fval, minval;
  64   int negative, prec;
  65   unsigned k;
  66   char formats[16];
  67
  68   prec = 0;
  69   negative = 0;
  70   if (n < 0.0)
  71     {
  72       negative = 1;
  73       n = -n;
  74     }
  75
  76   if (length >= 8)
  77     minval = FLT_MIN;
  78   else
  79     minval = DBL_MIN;
  80
  81
  82   if (n <= minval)
  83     {
  84       buffer[0] = '0';
  85       buffer[1] = '.';
  86       for (k = 2; k < 28 ; k++)
  87         buffer[k] = '0';
  88       buffer[k+1] = '\0';
  89       return buffer;
  90     }
  91   fval = n;
  92   while (fval > 1.0)
  93     {
  94       fval = fval / 10.0;
  95       prec ++;
  96     }
  97
  98   prec = sizeof (buffer) - 2 - prec;
  99   if (prec > 20)
 100      prec = 20;
 101   prec = prec > oprec ? oprec : prec ;
 102
 103   if (negative)
 104      sprintf (formats, "-%%.%df", prec);
 105   else
 106      sprintf (formats, "%%.%df", prec);
 107
 108   sprintf (buffer, formats, n);
 109   return buffer;
 110 }
 111
 112
 113 /* Returns a pointer to a static buffer. */
 114
 115 char *
 116 itoa (int64_t n)
 117 {
 118   int negative;
 119   char *p;
 120
 121   if (n == 0)
 122     {
 123       buffer[0] = '0';
 124       buffer[1] = '\0';
 125       return buffer;
 126     }
 127
 128   negative = 0;
 129   if (n < 0)
 130     {
 131       negative = 1;
 132       n = -n;
 133     }
 134
 135   p = buffer + sizeof (buffer) - 1;
 136   *p-- = '\0';
 137
 138   while (n != 0)
 139     {
 140       *p-- = '0' + (n % 10);
 141       n /= 10;
 142     }
 143
 144   if (negative)
 145     *p-- = '-';
 146   return ++p;
 147 }
 148
 149
 150 /* xtoa()-- Integer to hexadecimal conversion.  Returns a pointer to a
 151  * static buffer. */
 152
 153 char *
 154 xtoa (uint64_t n)
 155 {
 156   int digit;
 157   char *p;
 158
 159   if (n == 0)
 160     {
 161       buffer[0] = '0';
 162       buffer[1] = '\0';
 163       return buffer;
 164     }
 165
 166   p = buffer + sizeof (buffer) - 1;
 167   *p-- = '\0';
 168
 169   while (n != 0)
 170     {
 171       digit = n & 0xF;
 172       if (digit > 9)
 173         digit += 'A' - '0' - 10;
 174
 175       *p-- = '0' + digit;
 176       n >>= 4;
 177     }
 178
 179   return ++p;
 180 }
 181
 182
 183 /* st_printf()-- simple printf() function for streams that handles the
 184  * formats %d, %s and %c.  This function handles printing of error
 185  * messages that originate within the library itself, not from a user
 186  * program. */
 187
 188 int
 189 st_printf (const char *format, ...)
 190 {
 191   int count, total;
 192   va_list arg;
 193   char *p, *q;
 194   stream *s;
 195
 196   total = 0;
 197   s = init_error_stream ();
 198   va_start (arg, format);
 199
 200   for (;;)
 201     {
 202       count = 0;
 203
 204       while (format[count] != '%' && format[count] != '\0')
 205         count++;
 206
 207       if (count != 0)
 208         {
 209           p = salloc_w (s, &count);
 210           memmove (p, format, count);
 211           sfree (s);
 212         }
 213
 214       total += count;
 215       format += count;
 216       if (*format++ == '\0')
 217         break;
 218
 219       switch (*format)
 220         {
 221         case 'c':
 222           count = 1;
 223
 224           p = salloc_w (s, &count);
 225           *p = (char) va_arg (arg, int);
 226
 227           sfree (s);
 228           break;
 229
 230         case 'd':
 231           q = itoa (va_arg (arg, int));
 232           count = strlen (q);
 233
 234           p = salloc_w (s, &count);
 235           memmove (p, q, count);
 236           sfree (s);
 237           break;
 238
 239         case 'x':
 240           q = xtoa (va_arg (arg, unsigned));
 241           count = strlen (q);
 242
 243           p = salloc_w (s, &count);
 244           memmove (p, q, count);
 245           sfree (s);
 246           break;
 247
 248         case 's':
 249           q = va_arg (arg, char *);
 250           count = strlen (q);
 251
 252           p = salloc_w (s, &count);
 253           memmove (p, q, count);
 254           sfree (s);
 255           break;
 256
 257         case '\0':
 258           return total;
 259
 260         default:
 261           count = 2;
 262           p = salloc_w (s, &count);
 263           p[0] = format[-1];
 264           p[1] = format[0];
 265           sfree (s);
 266           break;
 267         }
 268
 269       total += count;
 270       format++;
 271     }
 272
 273   va_end (arg);
 274   return total;
 275 }
 276
 277
 278 /* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
 279
 280 void
 281 st_sprintf (char *buffer, const char *format, ...)
 282 {
 283   va_list arg;
 284   char c, *p;
 285   int count;
 286
 287   va_start (arg, format);
 288
 289   for (;;)
 290     {
 291       c = *format++;
 292       if (c != '%')
 293         {
 294           *buffer++ = c;
 295           if (c == '\0')
 296             break;
 297           continue;
 298         }
 299
 300       c = *format++;
 301       switch (c)
 302         {
 303         case 'c':
 304           *buffer++ = (char) va_arg (arg, int);
 305           break;
 306
 307         case 'd':
 308           p = itoa (va_arg (arg, int));
 309           count = strlen (p);
 310
 311           memcpy (buffer, p, count);
 312           buffer += count;
 313           break;
 314
 315         case 's':
 316           p = va_arg (arg, char *);
 317           count = strlen (p);
 318
 319           memcpy (buffer, p, count);
 320           buffer += count;
 321           break;
 322
 323         default:
 324           *buffer++ = c;
 325         }
 326     }
 327
 328   va_end (arg);
 329 }
 330
 331
 332 /* show_locus()-- Print a line number and filename describing where
 333  * something went wrong */
 334
 335 void
 336 show_locus (void)
 337 {
 338
 339   if (!options.locus || filename == NULL)
 340     return;
 341
 342   st_printf ("At line %d of file %s\n", line, filename);
 343 }
 344
 345
 346 /* recursion_check()-- It's possible for additional errors to occur
 347  * during fatal error processing.  We detect this condition here and
 348  * exit with code 4 immediately. */
 349
 350 #define MAGIC 0x20DE8101
 351
 352 static void
 353 recursion_check (void)
 354 {
 355   static int magic = 0;
 356
 357   if (magic == MAGIC)
 358     sys_exit (4);               /* Don't even try to print something at this point */
 359
 360   magic = MAGIC;
 361 }
 362
 363
 364 /* os_error()-- Operating system error.  We get a message from the
 365  * operating system, show it and leave.  Some operating system errors
 366  * are caught and processed by the library.  If not, we come here. */
 367
 368 void
 369 os_error (const char *message)
 370 {
 371
 372   recursion_check ();
 373
 374   show_locus ();
 375   st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
 376
 377   sys_exit (1);
 378 }
 379
 380
 381 /* void runtime_error()-- These are errors associated with an
 382  * invalid fortran program. */
 383
 384 void
 385 runtime_error (const char *message)
 386 {
 387
 388   recursion_check ();
 389
 390   show_locus ();
 391   st_printf ("Fortran runtime error: %s\n", message);
 392
 393   sys_exit (2);
 394 }
 395
 396
 397 /* void internal_error()-- These are this-can't-happen errors
 398  * that indicate something deeply wrong. */
 399
 400 void
 401 internal_error (const char *message)
 402 {
 403
 404   recursion_check ();
 405
 406   show_locus ();
 407   st_printf ("Internal Error: %s\n", message);
 408   sys_exit (3);
 409 }
 410
 411
 412 /* translate_error()-- Given an integer error code, return a string
 413  * describing the error. */
 414
 415 const char *
 416 translate_error (int code)
 417 {
 418   const char *p;
 419
 420   switch (code)
 421     {
 422     case ERROR_EOR:
 423       p = "End of record";
 424       break;
 425
 426     case ERROR_END:
 427       p = "End of file";
 428       break;
 429
 430     case ERROR_OK:
 431       p = "Successful return";
 432       break;
 433
 434     case ERROR_OS:
 435       p = "Operating system error";
 436       break;
 437
 438     case ERROR_BAD_OPTION:
 439       p = "Bad statement option";
 440       break;
 441
 442     case ERROR_MISSING_OPTION:
 443       p = "Missing statement option";
 444       break;
 445
 446     case ERROR_OPTION_CONFLICT:
 447       p = "Conflicting statement options";
 448       break;
 449
 450     case ERROR_ALREADY_OPEN:
 451       p = "File already opened in another unit";
 452       break;
 453
 454     case ERROR_BAD_UNIT:
 455       p = "Unattached unit";
 456       break;
 457
 458     case ERROR_FORMAT:
 459       p = "FORMAT error";
 460       break;
 461
 462     case ERROR_BAD_ACTION:
 463       p = "Incorrect ACTION specified";
 464       break;
 465
 466     case ERROR_ENDFILE:
 467       p = "Read past ENDFILE record";
 468       break;
 469
 470     case ERROR_BAD_US:
 471       p = "Corrupt unformatted sequential file";
 472       break;
 473
 474     case ERROR_READ_VALUE:
 475       p = "Bad value during read";
 476       break;
 477
 478     case ERROR_READ_OVERFLOW:
 479       p = "Numeric overflow on read";
 480       break;
 481
 482     default:
 483       p = "Unknown error code";
 484       break;
 485     }
 486
 487   return p;
 488 }
 489
 490
 491 /* generate_error()-- Come here when an error happens.  This
 492  * subroutine is called if it is possible to continue on after the
 493  * error.  If an IOSTAT variable exists, we set it.  If the IOSTAT or
 494  * ERR label is present, we return, otherwise we terminate the program
 495  * after print a message.  The error code is always required but the
 496  * message parameter can be NULL, in which case a string describing
 497  * the most recent operating system error is used. */
 498
 499 void
 500 generate_error (int family, const char *message)
 501 {
 502
 503   if (ioparm.iostat != NULL)
 504     {
 505       *ioparm.iostat = family;
 506       return;
 507     }
 508
 509   switch (family)
 510     {
 511     case ERROR_EOR:
 512       ioparm.library_return = LIBRARY_EOR;
 513       if (ioparm.eor != 0)
 514         return;
 515       break;
 516
 517     case ERROR_END:
 518       ioparm.library_return = LIBRARY_END;
 519       if (ioparm.end != 0)
 520         return;
 521       break;
 522
 523     default:
 524       ioparm.library_return = LIBRARY_ERROR;
 525       break;
 526     }
 527
 528   if (ioparm.err != 0)
 529     return;
 530
 531   /* Terminate the program */
 532
 533   if (message == NULL)
 534     message =
 535       (family == ERROR_OS) ? get_oserror () : translate_error (family);
 536
 537   runtime_error (message);
 538 }