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, 51 Franklin Street, Fifth Floor,
  28 Boston, MA 02110-1301, 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     case ERROR_ARRAY_STRIDE:
 435       p = "Array unit stride must be 1";
 436       break;
 437
 438     default:
 439       p = "Unknown error code";
 440       break;
 441     }
 442
 443   return p;
 444 }
 445
 446
 447 /* generate_error()-- Come here when an error happens.  This
 448  * subroutine is called if it is possible to continue on after the error.
 449  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 450  * ERR labels are present, we return, otherwise we terminate the program
 451  * after printing a message.  The error code is always required but the
 452  * message parameter can be NULL, in which case a string describing
 453  * the most recent operating system error is used. */
 454
 455 void
 456 generate_error (int family, const char *message)
 457 {
 458   /* Set the error status.  */
 459   if (ioparm.iostat != NULL)
 460     *ioparm.iostat = family;
 461
 462   if (message == NULL)
 463     message =
 464       (family == ERROR_OS) ? get_oserror () : translate_error (family);
 465
 466   if (ioparm.iomsg)
 467     cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message);
 468
 469   /* Report status back to the compiler.  */
 470   switch (family)
 471     {
 472     case ERROR_EOR:
 473       ioparm.library_return = LIBRARY_EOR;
 474       if (ioparm.eor != 0)
 475         return;
 476       break;
 477
 478     case ERROR_END:
 479       ioparm.library_return = LIBRARY_END;
 480       if (ioparm.end != 0)
 481         return;
 482       break;
 483
 484     default:
 485       ioparm.library_return = LIBRARY_ERROR;
 486       if (ioparm.err != 0)
 487         return;
 488       break;
 489     }
 490
 491   /* Return if the user supplied an iostat variable.  */
 492   if (ioparm.iostat != NULL)
 493     return;
 494
 495   /* Terminate the program */
 496
 497   runtime_error (message);
 498 }
 499
 500
 501
 502 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 503    feature.  An error/warning will be issued if the currently selected
 504    standard does not contain the requested bits.  */
 505
 506 try
 507 notify_std (int std, const char * message)
 508 {
 509   int warning;
 510
 511   warning = compile_options.warn_std & std;
 512   if ((compile_options.allow_std & std) != 0 && !warning)
 513     return SUCCESS;
 514
 515   show_locus ();
 516   if (!warning)
 517     {
 518       st_printf ("Fortran runtime error: %s\n", message);
 519       sys_exit (2);
 520     }
 521   else
 522     st_printf ("Fortran runtime warning: %s\n", message);
 523   return FAILURE;
 524 }