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