/fortranformat/spec/examples/gcc-4.4.0/libgfortran/runtime/error.c

/* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009
   Free Software Foundation, Inc.
   Contributed by Andy Vaught

This file is part of the GNU Fortran 95 runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */


#include "libgfortran.h"
#include <assert.h>
#include <string.h>
#include <errno.h>

#ifdef HAVE_SIGNAL_H
#include <signal.h>
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif

#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif

/* <sys/time.h> has to be included before <sys/resource.h> to work
   around PR 30518; otherwise, MacOS 10.3.9 headers are just broken.  */
#ifdef HAVE_SYS_RESOURCE_H
#include <sys/resource.h>
#endif


#ifdef __MINGW32__
#define HAVE_GETPID 1
#include <process.h>
#endif


/* sys_exit()-- Terminate the program with an exit code.  */

void
sys_exit (int code)
{
  /* Show error backtrace if possible.  */
  if (code != 0 && code != 4
      && (options.backtrace == 1
	  || (options.backtrace == -1 && compile_options.backtrace == 1)))
    show_backtrace ();

  /* Dump core if requested.  */
  if (code != 0
      && (options.dump_core == 1
	 || (options.dump_core == -1 && compile_options.dump_core == 1)))
    {
#if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
      /* Warn if a core file cannot be produced because
	 of core size limit.  */

      struct rlimit core_limit;

      if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0)
	st_printf ("** Warning: a core dump was requested, but the core size"
		   "limit\n**          is currently zero.\n\n");
#endif
      
      
#if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
      kill (getpid (), SIGQUIT);
#else
      st_printf ("Core dump not possible, sorry.");
#endif
    }

  exit (code);
}


/* Error conditions.  The tricky part here is printing a message when
 * it is the I/O subsystem that is severely wounded.  Our goal is to
 * try and print something making the fewest assumptions possible,
 * then try to clean up before actually exiting.
 *
 * The following exit conditions are defined:
 * 0    Normal program exit.
 * 1    Terminated because of operating system error.
 * 2    Error in the runtime library
 * 3    Internal error in runtime library
 * 4    Error during error processing (very bad)
 *
 * Other error returns are reserved for the STOP statement with a numeric code.
 */

/* gfc_itoa()-- Integer to decimal conversion. */

const char *
gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
{
  int negative;
  char *p;
  GFC_UINTEGER_LARGEST t;

  assert (len >= GFC_ITOA_BUF_SIZE);

  if (n == 0)
    return "0";

  negative = 0;
  t = n;
  if (n < 0)
    {
      negative = 1;
      t = -n; /*must use unsigned to protect from overflow*/
    }

  p = buffer + GFC_ITOA_BUF_SIZE - 1;
  *p = '\0';

  while (t != 0)
    {
      *--p = '0' + (t % 10);
      t /= 10;
    }

  if (negative)
    *--p = '-';
  return p;
}


/* xtoa()-- Integer to hexadecimal conversion.  */

const char *
xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
{
  int digit;
  char *p;

  assert (len >= GFC_XTOA_BUF_SIZE);

  if (n == 0)
    return "0";

  p = buffer + GFC_XTOA_BUF_SIZE - 1;
  *p = '\0';

  while (n != 0)
    {
      digit = n & 0xF;
      if (digit > 9)
	digit += 'A' - '0' - 10;

      *--p = '0' + digit;
      n >>= 4;
    }

  return p;
}

/* show_locus()-- Print a line number and filename describing where
 * something went wrong */

void
show_locus (st_parameter_common *cmp)
{
  static char *filename;

  if (!options.locus || cmp == NULL || cmp->filename == NULL)
    return;
  
  if (cmp->unit > 0)
    {
      filename = filename_from_unit (cmp->unit);
      if (filename != NULL)
	{
	  st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
		   (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
	  free_mem (filename);
	}
      else
	{
	  st_printf ("At line %d of file %s (unit = %d)\n",
		   (int) cmp->line, cmp->filename, (int) cmp->unit);
	}
      return;
    }

  st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
}


/* recursion_check()-- It's possible for additional errors to occur
 * during fatal error processing.  We detect this condition here and
 * exit with code 4 immediately. */

#define MAGIC 0x20DE8101

static void
recursion_check (void)
{
  static int magic = 0;

  /* Don't even try to print something at this point */
  if (magic == MAGIC)
    sys_exit (4);

  magic = MAGIC;
}


/* os_error()-- Operating system error.  We get a message from the
 * operating system, show it and leave.  Some operating system errors
 * are caught and processed by the library.  If not, we come here. */

void
os_error (const char *message)
{
  recursion_check ();
  st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
  sys_exit (1);
}
iexport(os_error);


/* void runtime_error()-- These are errors associated with an
 * invalid fortran program. */

void
runtime_error (const char *message, ...)
{
  va_list ap;

  recursion_check ();
  st_printf ("Fortran runtime error: ");
  va_start (ap, message);
  st_vprintf (message, ap);
  va_end (ap);
  st_printf ("\n");
  sys_exit (2);
}
iexport(runtime_error);

/* void runtime_error_at()-- These are errors associated with a
 * run time error generated by the front end compiler.  */

void
runtime_error_at (const char *where, const char *message, ...)
{
  va_list ap;

  recursion_check ();
  st_printf ("%s\n", where);
  st_printf ("Fortran runtime error: ");
  va_start (ap, message);
  st_vprintf (message, ap);
  va_end (ap);
  st_printf ("\n");
  sys_exit (2);
}
iexport(runtime_error_at);


void
runtime_warning_at (const char *where, const char *message, ...)
{
  va_list ap;

  st_printf ("%s\n", where);
  st_printf ("Fortran runtime warning: ");
  va_start (ap, message);
  st_vprintf (message, ap);
  va_end (ap);
  st_printf ("\n");
}
iexport(runtime_warning_at);


/* void internal_error()-- These are this-can't-happen errors
 * that indicate something deeply wrong. */

void
internal_error (st_parameter_common *cmp, const char *message)
{
  recursion_check ();
  show_locus (cmp);
  st_printf ("Internal Error: %s\n", message);

  /* This function call is here to get the main.o object file included
     when linking statically. This works because error.o is supposed to
     be always linked in (and the function call is in internal_error
     because hopefully it doesn't happen too often).  */
  stupid_function_name_for_static_linking();

  sys_exit (3);
}


/* translate_error()-- Given an integer error code, return a string
 * describing the error. */

const char *
translate_error (int code)
{
  const char *p;

  switch (code)
    {
    case LIBERROR_EOR:
      p = "End of record";
      break;

    case LIBERROR_END:
      p = "End of file";
      break;

    case LIBERROR_OK:
      p = "Successful return";
      break;

    case LIBERROR_OS:
      p = "Operating system error";
      break;

    case LIBERROR_BAD_OPTION:
      p = "Bad statement option";
      break;

    case LIBERROR_MISSING_OPTION:
      p = "Missing statement option";
      break;

    case LIBERROR_OPTION_CONFLICT:
      p = "Conflicting statement options";
      break;

    case LIBERROR_ALREADY_OPEN:
      p = "File already opened in another unit";
      break;

    case LIBERROR_BAD_UNIT:
      p = "Unattached unit";
      break;

    case LIBERROR_FORMAT:
      p = "FORMAT error";
      break;

    case LIBERROR_BAD_ACTION:
      p = "Incorrect ACTION specified";
      break;

    case LIBERROR_ENDFILE:
      p = "Read past ENDFILE record";
      break;

    case LIBERROR_BAD_US:
      p = "Corrupt unformatted sequential file";
      break;

    case LIBERROR_READ_VALUE:
      p = "Bad value during read";
      break;

    case LIBERROR_READ_OVERFLOW:
      p = "Numeric overflow on read";
      break;

    case LIBERROR_INTERNAL:
      p = "Internal error in run-time library";
      break;

    case LIBERROR_INTERNAL_UNIT:
      p = "Internal unit I/O error";
      break;

    case LIBERROR_DIRECT_EOR:
      p = "Write exceeds length of DIRECT access record";
      break;

    case LIBERROR_SHORT_RECORD:
      p = "I/O past end of record on unformatted file";
      break;

    case LIBERROR_CORRUPT_FILE:
      p = "Unformatted file structure has been corrupted";
      break;

    default:
      p = "Unknown error code";
      break;
    }

  return p;
}


/* generate_error()-- Come here when an error happens.  This
 * subroutine is called if it is possible to continue on after the error.
 * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
 * ERR labels are present, we return, otherwise we terminate the program
 * after printing a message.  The error code is always required but the
 * message parameter can be NULL, in which case a string describing
 * the most recent operating system error is used. */

void
generate_error (st_parameter_common *cmp, int family, const char *message)
{

  /* If there was a previous error, don't mask it with another
     error message, EOF or EOR condition.  */

  if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
    return;

  /* Set the error status.  */
  if ((cmp->flags & IOPARM_HAS_IOSTAT))
    *cmp->iostat = (family == LIBERROR_OS) ? errno : family;

  if (message == NULL)
    message =
      (family == LIBERROR_OS) ? get_oserror () : translate_error (family);

  if (cmp->flags & IOPARM_HAS_IOMSG)
    cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);

  /* Report status back to the compiler.  */
  cmp->flags &= ~IOPARM_LIBRETURN_MASK;
  switch (family)
    {
    case LIBERROR_EOR:
      cmp->flags |= IOPARM_LIBRETURN_EOR;
      if ((cmp->flags & IOPARM_EOR))
	return;
      break;

    case LIBERROR_END:
      cmp->flags |= IOPARM_LIBRETURN_END;
      if ((cmp->flags & IOPARM_END))
	return;
      break;

    default:
      cmp->flags |= IOPARM_LIBRETURN_ERROR;
      if ((cmp->flags & IOPARM_ERR))
	return;
      break;
    }

  /* Return if the user supplied an iostat variable.  */
  if ((cmp->flags & IOPARM_HAS_IOSTAT))
    return;

  /* Terminate the program */

  recursion_check ();
  show_locus (cmp);
  st_printf ("Fortran runtime error: %s\n", message);
  sys_exit (2);
}
iexport(generate_error);

/* Whether, for a feature included in a given standard set (GFC_STD_*),
   we should issue an error or a warning, or be quiet.  */

notification
notification_std (int std)
{
  int warning;

  if (!compile_options.pedantic)
    return SILENT;

  warning = compile_options.warn_std & std;
  if ((compile_options.allow_std & std) != 0 && !warning)
    return SILENT;

  return warning ? WARNING : ERROR;
}



/* Possibly issue a warning/error about use of a nonstandard (or deleted)
   feature.  An error/warning will be issued if the currently selected
   standard does not contain the requested bits.  */

try
notify_std (st_parameter_common *cmp, int std, const char * message)
{
  int warning;

  if (!compile_options.pedantic)
    return SUCCESS;

  warning = compile_options.warn_std & std;
  if ((compile_options.allow_std & std) != 0 && !warning)
    return SUCCESS;

  if (!warning)
    {
      recursion_check ();
      show_locus (cmp);
      st_printf ("Fortran runtime error: %s\n", message);
      sys_exit (2);
    }
  else
    {
      show_locus (cmp);
      st_printf ("Fortran runtime warning: %s\n", message);
    }
  return FAILURE;
}