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