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