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
 357   /* This function call is here to get the main.o object file included
 358      when linking statically. This works because error.o is supposed to
 359      be always linked in (and the function call is in internal_error
 360      because hopefully it doesn't happen too often).  */
 361   stupid_function_name_for_static_linking();
 362
 363   sys_exit (3);
 364 }
 365
 366
 367 /* translate_error()-- Given an integer error code, return a string
 368  * describing the error. */
 369
 370 const char *
 371 translate_error (int code)
 372 {
 373   const char *p;
 374
 375   switch (code)
 376     {
 377     case ERROR_EOR:
 378       p = "End of record";
 379       break;
 380
 381     case ERROR_END:
 382       p = "End of file";
 383       break;
 384
 385     case ERROR_OK:
 386       p = "Successful return";
 387       break;
 388
 389     case ERROR_OS:
 390       p = "Operating system error";
 391       break;
 392
 393     case ERROR_BAD_OPTION:
 394       p = "Bad statement option";
 395       break;
 396
 397     case ERROR_MISSING_OPTION:
 398       p = "Missing statement option";
 399       break;
 400
 401     case ERROR_OPTION_CONFLICT:
 402       p = "Conflicting statement options";
 403       break;
 404
 405     case ERROR_ALREADY_OPEN:
 406       p = "File already opened in another unit";
 407       break;
 408
 409     case ERROR_BAD_UNIT:
 410       p = "Unattached unit";
 411       break;
 412
 413     case ERROR_FORMAT:
 414       p = "FORMAT error";
 415       break;
 416
 417     case ERROR_BAD_ACTION:
 418       p = "Incorrect ACTION specified";
 419       break;
 420
 421     case ERROR_ENDFILE:
 422       p = "Read past ENDFILE record";
 423       break;
 424
 425     case ERROR_BAD_US:
 426       p = "Corrupt unformatted sequential file";
 427       break;
 428
 429     case ERROR_READ_VALUE:
 430       p = "Bad value during read";
 431       break;
 432
 433     case ERROR_READ_OVERFLOW:
 434       p = "Numeric overflow on read";
 435       break;
 436
 437     default:
 438       p = "Unknown error code";
 439       break;
 440     }
 441
 442   return p;
 443 }
 444
 445
 446 /* generate_error()-- Come here when an error happens.  This
 447  * subroutine is called if it is possible to continue on after the error.
 448  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 449  * ERR labels are present, we return, otherwise we terminate the program
 450  * after printing a message.  The error code is always required but the
 451  * message parameter can be NULL, in which case a string describing
 452  * the most recent operating system error is used. */
 453
 454 void
 455 generate_error (int family, const char *message)
 456 {
 457   /* Set the error status.  */
 458   if (ioparm.iostat != NULL)
 459     *ioparm.iostat = family;
 460
 461   if (message == NULL)
 462     message =
 463       (family == ERROR_OS) ? get_oserror () : translate_error (family);
 464
 465   if (ioparm.iomsg)
 466     cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message);
 467
 468   /* Report status back to the compiler.  */
 469   switch (family)
 470     {
 471     case ERROR_EOR:
 472       ioparm.library_return = LIBRARY_EOR;
 473       if (ioparm.eor != 0)
 474         return;
 475       break;
 476
 477     case ERROR_END:
 478       ioparm.library_return = LIBRARY_END;
 479       if (ioparm.end != 0)
 480         return;
 481       break;
 482
 483     default:
 484       ioparm.library_return = LIBRARY_ERROR;
 485       if (ioparm.err != 0)
 486         return;
 487       break;
 488     }
 489
 490   /* Return if the user supplied an iostat variable.  */
 491   if (ioparm.iostat != NULL)
 492     return;
 493
 494   /* Terminate the program */
 495
 496   runtime_error (message);
 497 }
 498
 499
 500
 501 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 502    feature.  An error/warning will be issued if the currently selected
 503    standard does not contain the requested bits.  */
 504
 505 try
 506 notify_std (int std, const char * message)
 507 {
 508   int warning;
 509
 510   warning = compile_options.warn_std & std;
 511   if ((compile_options.allow_std & std) != 0 && !warning)
 512     return SUCCESS;
 513
 514   show_locus ();
 515   if (!warning)
 516     {
 517       st_printf ("Fortran runtime error: %s\n", message);
 518       sys_exit (2);
 519     }
 520   else
 521     st_printf ("Fortran runtime warning: %s\n", message);
 522   return FAILURE;
 523 }