libgfortran/runtime/error.c

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