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