PageRenderTime 4ms CodeModel.GetById 2ms app.highlight 19ms RepoModel.GetById 1ms app.codeStats 0ms

/libgfortran/runtime/error.c

https://bitbucket.org/bluezoo/gcc
C | 619 lines | 366 code | 127 blank | 126 comment | 48 complexity | 7ac70c91269f8dc949f0aef01a7455e6 MD5 | raw file
  1/* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009, 2010, 2011
  2   Free Software Foundation, Inc.
  3   Contributed by Andy Vaught
  4
  5This file is part of the GNU Fortran runtime library (libgfortran).
  6
  7Libgfortran is free software; you can redistribute it and/or modify
  8it under the terms of the GNU General Public License as published by
  9the Free Software Foundation; either version 3, or (at your option)
 10any later version.
 11
 12Libgfortran is distributed in the hope that it will be useful,
 13but WITHOUT ANY WARRANTY; without even the implied warranty of
 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 15GNU General Public License for more details.
 16
 17Under Section 7 of GPL version 3, you are granted additional
 18permissions described in the GCC Runtime Library Exception, version
 193.1, as published by the Free Software Foundation.
 20
 21You should have received a copy of the GNU General Public License and
 22a copy of the GCC Runtime Library Exception along with this program;
 23see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 24<http://www.gnu.org/licenses/>.  */
 25
 26
 27#include "libgfortran.h"
 28#include <assert.h>
 29#include <string.h>
 30#include <errno.h>
 31#include <signal.h>
 32
 33#ifdef HAVE_UNISTD_H
 34#include <unistd.h>
 35#endif
 36
 37#include <stdlib.h>
 38
 39#ifdef HAVE_SYS_TIME_H
 40#include <sys/time.h>
 41#endif
 42
 43/* <sys/time.h> has to be included before <sys/resource.h> to work
 44   around PR 30518; otherwise, MacOS 10.3.9 headers are just broken.  */
 45#ifdef HAVE_SYS_RESOURCE_H
 46#include <sys/resource.h>
 47#endif
 48
 49
 50#ifdef __MINGW32__
 51#define HAVE_GETPID 1
 52#include <process.h>
 53#endif
 54
 55
 56/* Termination of a program: F2008 2.3.5 talks about "normal
 57   termination" and "error termination". Normal termination occurs as
 58   a result of e.g. executing the end program statement, and executing
 59   the STOP statement. It includes the effect of the C exit()
 60   function. 
 61
 62   Error termination is initiated when the ERROR STOP statement is
 63   executed, when ALLOCATE/DEALLOCATE fails without STAT= being
 64   specified, when some of the co-array synchronization statements
 65   fail without STAT= being specified, and some I/O errors if
 66   ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE
 67   failure without CMDSTAT=.
 68
 69   2.3.5 also explains how co-images synchronize during termination.
 70
 71   In libgfortran we have two ways of ending a program. exit(code) is
 72   a normal exit; calling exit() also causes open units to be
 73   closed. No backtrace or core dump is needed here. When something
 74   goes wrong, we have sys_abort() which tries to print the backtrace
 75   if -fbacktrace is enabled, and then dumps core; whether a core file
 76   is generated is system dependent. When aborting, we don't flush and
 77   close open units, as program memory might be corrupted and we'd
 78   rather risk losing dirty data in the buffers rather than corrupting
 79   files on disk.
 80
 81*/
 82
 83/* Error conditions.  The tricky part here is printing a message when
 84 * it is the I/O subsystem that is severely wounded.  Our goal is to
 85 * try and print something making the fewest assumptions possible,
 86 * then try to clean up before actually exiting.
 87 *
 88 * The following exit conditions are defined:
 89 * 0    Normal program exit.
 90 * 1    Terminated because of operating system error.
 91 * 2    Error in the runtime library
 92 * 3    Internal error in runtime library
 93 *
 94 * Other error returns are reserved for the STOP statement with a numeric code.
 95 */
 96
 97
 98/* Write a null-terminated C string to standard error. This function
 99   is async-signal-safe.  */
100
101ssize_t
102estr_write (const char *str)
103{
104  return write (STDERR_FILENO, str, strlen (str));
105}
106
107
108/* st_vprintf()-- vsnprintf-like function for error output.  We use a
109   stack allocated buffer for formatting; since this function might be
110   called from within a signal handler, printing directly to stderr
111   with vfprintf is not safe since the stderr locking might lead to a
112   deadlock.  */
113
114#define ST_VPRINTF_SIZE 512
115
116int
117st_vprintf (const char *format, va_list ap)
118{
119  int written;
120  char buffer[ST_VPRINTF_SIZE];
121
122#ifdef HAVE_VSNPRINTF
123  written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
124#else
125  written = vsprintf(buffer, format, ap);
126
127  if (written >= ST_VPRINTF_SIZE - 1)
128    {
129      /* The error message was longer than our buffer.  Ouch.  Because
130	 we may have messed up things badly, report the error and
131	 quit.  */
132#define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
133      write (STDERR_FILENO, buffer, ST_VPRINTF_SIZE - 1);
134      write (STDERR_FILENO, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
135      sys_abort ();
136#undef ERROR_MESSAGE
137
138    }
139#endif
140
141  written = write (STDERR_FILENO, buffer, written);
142  return written;
143}
144
145
146int
147st_printf (const char * format, ...)
148{
149  int written;
150  va_list ap;
151  va_start (ap, format);
152  written = st_vprintf (format, ap);
153  va_end (ap);
154  return written;
155}
156
157
158/* sys_abort()-- Terminate the program showing backtrace and dumping
159   core.  */
160
161void
162sys_abort (void)
163{
164  /* If backtracing is enabled, print backtrace and disable signal
165     handler for ABRT.  */
166  if (options.backtrace == 1
167      || (options.backtrace == -1 && compile_options.backtrace == 1))
168    {
169      estr_write ("\nProgram aborted. Backtrace:\n");
170      backtrace ();
171      signal (SIGABRT, SIG_DFL);
172    }
173
174  abort();
175}
176
177
178/* gfc_xtoa()-- Integer to hexadecimal conversion.  */
179
180const char *
181gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
182{
183  int digit;
184  char *p;
185
186  assert (len >= GFC_XTOA_BUF_SIZE);
187
188  if (n == 0)
189    return "0";
190
191  p = buffer + GFC_XTOA_BUF_SIZE - 1;
192  *p = '\0';
193
194  while (n != 0)
195    {
196      digit = n & 0xF;
197      if (digit > 9)
198	digit += 'A' - '0' - 10;
199
200      *--p = '0' + digit;
201      n >>= 4;
202    }
203
204  return p;
205}
206
207
208/* Hopefully thread-safe wrapper for a strerror_r() style function.  */
209
210char *
211gf_strerror (int errnum, 
212             char * buf __attribute__((unused)), 
213	     size_t buflen __attribute__((unused)))
214{
215#ifdef HAVE_STRERROR_R
216  /* POSIX returns an "int", GNU a "char*".  */
217  return
218    __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0))
219			   == 5,
220			   /* GNU strerror_r()  */
221			   strerror_r (errnum, buf, buflen),
222			   /* POSIX strerror_r ()  */
223			   (strerror_r (errnum, buf, buflen), buf));
224#elif defined(HAVE_STRERROR_R_2ARGS)
225  strerror_r (errnum, buf);
226  return buf;
227#else
228  /* strerror () is not necessarily thread-safe, but should at least
229     be available everywhere.  */
230  return strerror (errnum);
231#endif
232}
233
234
235/* show_locus()-- Print a line number and filename describing where
236 * something went wrong */
237
238void
239show_locus (st_parameter_common *cmp)
240{
241  char *filename;
242
243  if (!options.locus || cmp == NULL || cmp->filename == NULL)
244    return;
245  
246  if (cmp->unit > 0)
247    {
248      filename = filename_from_unit (cmp->unit);
249
250      if (filename != NULL)
251	{
252	  st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
253		   (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
254	  free (filename);
255	}
256      else
257	{
258	  st_printf ("At line %d of file %s (unit = %d)\n",
259		   (int) cmp->line, cmp->filename, (int) cmp->unit);
260	}
261      return;
262    }
263
264  st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
265}
266
267
268/* recursion_check()-- It's possible for additional errors to occur
269 * during fatal error processing.  We detect this condition here and
270 * exit with code 4 immediately. */
271
272#define MAGIC 0x20DE8101
273
274static void
275recursion_check (void)
276{
277  static int magic = 0;
278
279  /* Don't even try to print something at this point */
280  if (magic == MAGIC)
281    sys_abort ();
282
283  magic = MAGIC;
284}
285
286
287#define STRERR_MAXSZ 256
288
289/* os_error()-- Operating system error.  We get a message from the
290 * operating system, show it and leave.  Some operating system errors
291 * are caught and processed by the library.  If not, we come here. */
292
293void
294os_error (const char *message)
295{
296  char errmsg[STRERR_MAXSZ];
297  recursion_check ();
298  estr_write ("Operating system error: ");
299  estr_write (gf_strerror (errno, errmsg, STRERR_MAXSZ));
300  estr_write ("\n");
301  estr_write (message);
302  estr_write ("\n");
303  exit (1);
304}
305iexport(os_error);
306
307
308/* void runtime_error()-- These are errors associated with an
309 * invalid fortran program. */
310
311void
312runtime_error (const char *message, ...)
313{
314  va_list ap;
315
316  recursion_check ();
317  estr_write ("Fortran runtime error: ");
318  va_start (ap, message);
319  st_vprintf (message, ap);
320  va_end (ap);
321  estr_write ("\n");
322  exit (2);
323}
324iexport(runtime_error);
325
326/* void runtime_error_at()-- These are errors associated with a
327 * run time error generated by the front end compiler.  */
328
329void
330runtime_error_at (const char *where, const char *message, ...)
331{
332  va_list ap;
333
334  recursion_check ();
335  estr_write (where);
336  estr_write ("\nFortran runtime error: ");
337  va_start (ap, message);
338  st_vprintf (message, ap);
339  va_end (ap);
340  estr_write ("\n");
341  exit (2);
342}
343iexport(runtime_error_at);
344
345
346void
347runtime_warning_at (const char *where, const char *message, ...)
348{
349  va_list ap;
350
351  estr_write (where);
352  estr_write ("\nFortran runtime warning: ");
353  va_start (ap, message);
354  st_vprintf (message, ap);
355  va_end (ap);
356  estr_write ("\n");
357}
358iexport(runtime_warning_at);
359
360
361/* void internal_error()-- These are this-can't-happen errors
362 * that indicate something deeply wrong. */
363
364void
365internal_error (st_parameter_common *cmp, const char *message)
366{
367  recursion_check ();
368  show_locus (cmp);
369  estr_write ("Internal Error: ");
370  estr_write (message);
371  estr_write ("\n");
372
373  /* This function call is here to get the main.o object file included
374     when linking statically. This works because error.o is supposed to
375     be always linked in (and the function call is in internal_error
376     because hopefully it doesn't happen too often).  */
377  stupid_function_name_for_static_linking();
378
379  exit (3);
380}
381
382
383/* translate_error()-- Given an integer error code, return a string
384 * describing the error. */
385
386const char *
387translate_error (int code)
388{
389  const char *p;
390
391  switch (code)
392    {
393    case LIBERROR_EOR:
394      p = "End of record";
395      break;
396
397    case LIBERROR_END:
398      p = "End of file";
399      break;
400
401    case LIBERROR_OK:
402      p = "Successful return";
403      break;
404
405    case LIBERROR_OS:
406      p = "Operating system error";
407      break;
408
409    case LIBERROR_BAD_OPTION:
410      p = "Bad statement option";
411      break;
412
413    case LIBERROR_MISSING_OPTION:
414      p = "Missing statement option";
415      break;
416
417    case LIBERROR_OPTION_CONFLICT:
418      p = "Conflicting statement options";
419      break;
420
421    case LIBERROR_ALREADY_OPEN:
422      p = "File already opened in another unit";
423      break;
424
425    case LIBERROR_BAD_UNIT:
426      p = "Unattached unit";
427      break;
428
429    case LIBERROR_FORMAT:
430      p = "FORMAT error";
431      break;
432
433    case LIBERROR_BAD_ACTION:
434      p = "Incorrect ACTION specified";
435      break;
436
437    case LIBERROR_ENDFILE:
438      p = "Read past ENDFILE record";
439      break;
440
441    case LIBERROR_BAD_US:
442      p = "Corrupt unformatted sequential file";
443      break;
444
445    case LIBERROR_READ_VALUE:
446      p = "Bad value during read";
447      break;
448
449    case LIBERROR_READ_OVERFLOW:
450      p = "Numeric overflow on read";
451      break;
452
453    case LIBERROR_INTERNAL:
454      p = "Internal error in run-time library";
455      break;
456
457    case LIBERROR_INTERNAL_UNIT:
458      p = "Internal unit I/O error";
459      break;
460
461    case LIBERROR_DIRECT_EOR:
462      p = "Write exceeds length of DIRECT access record";
463      break;
464
465    case LIBERROR_SHORT_RECORD:
466      p = "I/O past end of record on unformatted file";
467      break;
468
469    case LIBERROR_CORRUPT_FILE:
470      p = "Unformatted file structure has been corrupted";
471      break;
472
473    default:
474      p = "Unknown error code";
475      break;
476    }
477
478  return p;
479}
480
481
482/* generate_error()-- Come here when an error happens.  This
483 * subroutine is called if it is possible to continue on after the error.
484 * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
485 * ERR labels are present, we return, otherwise we terminate the program
486 * after printing a message.  The error code is always required but the
487 * message parameter can be NULL, in which case a string describing
488 * the most recent operating system error is used. */
489
490void
491generate_error (st_parameter_common *cmp, int family, const char *message)
492{
493  char errmsg[STRERR_MAXSZ];
494
495  /* If there was a previous error, don't mask it with another
496     error message, EOF or EOR condition.  */
497
498  if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
499    return;
500
501  /* Set the error status.  */
502  if ((cmp->flags & IOPARM_HAS_IOSTAT))
503    *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
504
505  if (message == NULL)
506    message =
507      (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
508      translate_error (family);
509
510  if (cmp->flags & IOPARM_HAS_IOMSG)
511    cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
512
513  /* Report status back to the compiler.  */
514  cmp->flags &= ~IOPARM_LIBRETURN_MASK;
515  switch (family)
516    {
517    case LIBERROR_EOR:
518      cmp->flags |= IOPARM_LIBRETURN_EOR;
519      if ((cmp->flags & IOPARM_EOR))
520	return;
521      break;
522
523    case LIBERROR_END:
524      cmp->flags |= IOPARM_LIBRETURN_END;
525      if ((cmp->flags & IOPARM_END))
526	return;
527      break;
528
529    default:
530      cmp->flags |= IOPARM_LIBRETURN_ERROR;
531      if ((cmp->flags & IOPARM_ERR))
532	return;
533      break;
534    }
535
536  /* Return if the user supplied an iostat variable.  */
537  if ((cmp->flags & IOPARM_HAS_IOSTAT))
538    return;
539
540  /* Terminate the program */
541
542  recursion_check ();
543  show_locus (cmp);
544  estr_write ("Fortran runtime error: ");
545  estr_write (message);
546  estr_write ("\n");
547  exit (2);
548}
549iexport(generate_error);
550
551
552/* generate_warning()-- Similar to generate_error but just give a warning.  */
553
554void
555generate_warning (st_parameter_common *cmp, const char *message)
556{
557  if (message == NULL)
558    message = " ";
559
560  show_locus (cmp);
561  estr_write ("Fortran runtime warning: ");
562  estr_write (message);
563  estr_write ("\n");
564}
565
566
567/* Whether, for a feature included in a given standard set (GFC_STD_*),
568   we should issue an error or a warning, or be quiet.  */
569
570notification
571notification_std (int std)
572{
573  int warning;
574
575  if (!compile_options.pedantic)
576    return NOTIFICATION_SILENT;
577
578  warning = compile_options.warn_std & std;
579  if ((compile_options.allow_std & std) != 0 && !warning)
580    return NOTIFICATION_SILENT;
581
582  return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
583}
584
585
586/* Possibly issue a warning/error about use of a nonstandard (or deleted)
587   feature.  An error/warning will be issued if the currently selected
588   standard does not contain the requested bits.  */
589
590try
591notify_std (st_parameter_common *cmp, int std, const char * message)
592{
593  int warning;
594
595  if (!compile_options.pedantic)
596    return SUCCESS;
597
598  warning = compile_options.warn_std & std;
599  if ((compile_options.allow_std & std) != 0 && !warning)
600    return SUCCESS;
601
602  if (!warning)
603    {
604      recursion_check ();
605      show_locus (cmp);
606      estr_write ("Fortran runtime error: ");
607      estr_write (message);
608      estr_write ("\n");
609      exit (2);
610    }
611  else
612    {
613      show_locus (cmp);
614      estr_write ("Fortran runtime warning: ");
615      estr_write (message);
616      estr_write ("\n");
617    }
618  return FAILURE;
619}