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
  57 /* Returns a pointer to a static buffer. */
  58
  59 char *
  60 itoa (int64_t n)
  61 {
  62   int negative;
  63   char *p;
  64   uint64_t t;
  65
  66   if (n == 0)
  67     {
  68       buffer[0] = '0';
  69       buffer[1] = '\0';
  70       return buffer;
  71     }
  72
  73   negative = 0;
  74   t = n;
  75   if (n < 0)
  76     {
  77       negative = 1;
  78       t = -n; /*must use unsigned to protect from overflow*/
  79     }
  80
  81   p = buffer + sizeof (buffer) - 1;
  82   *p-- = '\0';
  83
  84   while (t != 0)
  85     {
  86       *p-- = '0' + (t % 10);
  87       t /= 10;
  88     }
  89
  90   if (negative)
  91     *p-- = '-';
  92   return ++p;
  93 }
  94
  95
  96 /* xtoa()-- Integer to hexadecimal conversion.  Returns a pointer to a
  97  * static buffer. */
  98
  99 char *
 100 xtoa (uint64_t n)
 101 {
 102   int digit;
 103   char *p;
 104
 105   if (n == 0)
 106     {
 107       buffer[0] = '0';
 108       buffer[1] = '\0';
 109       return buffer;
 110     }
 111
 112   p = buffer + sizeof (buffer) - 1;
 113   *p-- = '\0';
 114
 115   while (n != 0)
 116     {
 117       digit = n & 0xF;
 118       if (digit > 9)
 119         digit += 'A' - '0' - 10;
 120
 121       *p-- = '0' + digit;
 122       n >>= 4;
 123     }
 124
 125   return ++p;
 126 }
 127
 128
 129 /* st_printf()-- simple printf() function for streams that handles the
 130  * formats %d, %s and %c.  This function handles printing of error
 131  * messages that originate within the library itself, not from a user
 132  * program. */
 133
 134 int
 135 st_printf (const char *format, ...)
 136 {
 137   int count, total;
 138   va_list arg;
 139   char *p, *q;
 140   stream *s;
 141
 142   total = 0;
 143   s = init_error_stream ();
 144   va_start (arg, format);
 145
 146   for (;;)
 147     {
 148       count = 0;
 149
 150       while (format[count] != '%' && format[count] != '\0')
 151         count++;
 152
 153       if (count != 0)
 154         {
 155           p = salloc_w (s, &count);
 156           memmove (p, format, count);
 157           sfree (s);
 158         }
 159
 160       total += count;
 161       format += count;
 162       if (*format++ == '\0')
 163         break;
 164
 165       switch (*format)
 166         {
 167         case 'c':
 168           count = 1;
 169
 170           p = salloc_w (s, &count);
 171           *p = (char) va_arg (arg, int);
 172
 173           sfree (s);
 174           break;
 175
 176         case 'd':
 177           q = itoa (va_arg (arg, int));
 178           count = strlen (q);
 179
 180           p = salloc_w (s, &count);
 181           memmove (p, q, count);
 182           sfree (s);
 183           break;
 184
 185         case 'x':
 186           q = xtoa (va_arg (arg, unsigned));
 187           count = strlen (q);
 188
 189           p = salloc_w (s, &count);
 190           memmove (p, q, count);
 191           sfree (s);
 192           break;
 193
 194         case 's':
 195           q = va_arg (arg, char *);
 196           count = strlen (q);
 197
 198           p = salloc_w (s, &count);
 199           memmove (p, q, count);
 200           sfree (s);
 201           break;
 202
 203         case '\0':
 204           return total;
 205
 206         default:
 207           count = 2;
 208           p = salloc_w (s, &count);
 209           p[0] = format[-1];
 210           p[1] = format[0];
 211           sfree (s);
 212           break;
 213         }
 214
 215       total += count;
 216       format++;
 217     }
 218
 219   va_end (arg);
 220   return total;
 221 }
 222
 223
 224 /* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
 225
 226 void
 227 st_sprintf (char *buffer, const char *format, ...)
 228 {
 229   va_list arg;
 230   char c, *p;
 231   int count;
 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 = itoa (va_arg (arg, int));
 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 (void)
 283 {
 284
 285   if (!options.locus || filename == NULL)
 286     return;
 287
 288   st_printf ("At line %d of file %s\n", line, filename);
 289 }
 290
 291
 292 /* recursion_check()-- It's possible for additional errors to occur
 293  * during fatal error processing.  We detect this condition here and
 294  * exit with code 4 immediately. */
 295
 296 #define MAGIC 0x20DE8101
 297
 298 static void
 299 recursion_check (void)
 300 {
 301   static int magic = 0;
 302
 303   if (magic == MAGIC)
 304     sys_exit (4);               /* Don't even try to print something at this point */
 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
 318   recursion_check ();
 319
 320   show_locus ();
 321   st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
 322
 323   sys_exit (1);
 324 }
 325
 326
 327 /* void runtime_error()-- These are errors associated with an
 328  * invalid fortran program. */
 329
 330 void
 331 runtime_error (const char *message)
 332 {
 333
 334   recursion_check ();
 335
 336   show_locus ();
 337   st_printf ("Fortran runtime error: %s\n", message);
 338
 339   sys_exit (2);
 340 }
 341
 342
 343 /* void internal_error()-- These are this-can't-happen errors
 344  * that indicate something deeply wrong. */
 345
 346 void
 347 internal_error (const char *message)
 348 {
 349
 350   recursion_check ();
 351
 352   show_locus ();
 353   st_printf ("Internal Error: %s\n", message);
 354   sys_exit (3);
 355 }
 356
 357
 358 /* translate_error()-- Given an integer error code, return a string
 359  * describing the error. */
 360
 361 const char *
 362 translate_error (int code)
 363 {
 364   const char *p;
 365
 366   switch (code)
 367     {
 368     case ERROR_EOR:
 369       p = "End of record";
 370       break;
 371
 372     case ERROR_END:
 373       p = "End of file";
 374       break;
 375
 376     case ERROR_OK:
 377       p = "Successful return";
 378       break;
 379
 380     case ERROR_OS:
 381       p = "Operating system error";
 382       break;
 383
 384     case ERROR_BAD_OPTION:
 385       p = "Bad statement option";
 386       break;
 387
 388     case ERROR_MISSING_OPTION:
 389       p = "Missing statement option";
 390       break;
 391
 392     case ERROR_OPTION_CONFLICT:
 393       p = "Conflicting statement options";
 394       break;
 395
 396     case ERROR_ALREADY_OPEN:
 397       p = "File already opened in another unit";
 398       break;
 399
 400     case ERROR_BAD_UNIT:
 401       p = "Unattached unit";
 402       break;
 403
 404     case ERROR_FORMAT:
 405       p = "FORMAT error";
 406       break;
 407
 408     case ERROR_BAD_ACTION:
 409       p = "Incorrect ACTION specified";
 410       break;
 411
 412     case ERROR_ENDFILE:
 413       p = "Read past ENDFILE record";
 414       break;
 415
 416     case ERROR_BAD_US:
 417       p = "Corrupt unformatted sequential file";
 418       break;
 419
 420     case ERROR_READ_VALUE:
 421       p = "Bad value during read";
 422       break;
 423
 424     case ERROR_READ_OVERFLOW:
 425       p = "Numeric overflow on read";
 426       break;
 427
 428     default:
 429       p = "Unknown error code";
 430       break;
 431     }
 432
 433   return p;
 434 }
 435
 436
 437 /* generate_error()-- Come here when an error happens.  This
 438  * subroutine is called if it is possible to continue on after the
 439  * error.  If an IOSTAT variable exists, we set it.  If the IOSTAT or
 440  * ERR label is present, we return, otherwise we terminate the program
 441  * after print a message.  The error code is always required but the
 442  * message parameter can be NULL, in which case a string describing
 443  * the most recent operating system error is used. */
 444
 445 void
 446 generate_error (int family, const char *message)
 447 {
 448   /* Set the error status.  */
 449   if (ioparm.iostat != NULL)
 450     *ioparm.iostat = family;
 451
 452   /* Report status back to the compiler.  */
 453   switch (family)
 454     {
 455     case ERROR_EOR:
 456       ioparm.library_return = LIBRARY_EOR;
 457       if (ioparm.eor != 0)
 458         return;
 459       break;
 460
 461     case ERROR_END:
 462       ioparm.library_return = LIBRARY_END;
 463       if (ioparm.end != 0)
 464         return;
 465       break;
 466
 467     default:
 468       ioparm.library_return = LIBRARY_ERROR;
 469       if (ioparm.err != 0)
 470         return;
 471       break;
 472     }
 473
 474   /* Return if the user supplied an iostat variable.  */
 475   if (ioparm.iostat != NULL)
 476     return;
 477
 478   /* Terminate the program */
 479
 480   if (message == NULL)
 481     message =
 482       (family == ERROR_OS) ? get_oserror () : translate_error (family);
 483
 484   runtime_error (message);
 485 }