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