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