libgfortran/runtime/error.c

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