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