[gcc.git] / libgfortran / runtime / error.c

/* Copyright (C) 2002, 2003, 2005 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 2, or (at your option)
any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public License
along with libgfortran; see the file COPYING.  If not, write to
the Free Software Foundation, 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */


#include "config.h"
#include <stdio.h>
#include <stdarg.h>
#include <string.h>
#include <float.h>

#include "libgfortran.h"
#include "../io/io.h"

/* 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.
 */

/* locus variables.  These are optionally set by a caller before a
 * library subroutine is called.  They are always cleared on exit so
 * that files that report loci and those that do not can be linked
 * together without reporting an erroneous position. */

char *filename = 0;
iexport_data(filename);

unsigned line = 0;
iexport_data(line);

/* buffer for integer/ascii conversions.  */
static char buffer[sizeof (GFC_UINTEGER_LARGEST) * 8 + 1];


/* Returns a pointer to a static buffer. */

char *
gfc_itoa (GFC_INTEGER_LARGEST n)
{
  int negative;
  char *p;
  GFC_UINTEGER_LARGEST t;

  if (n == 0)
    {
      buffer[0] = '0';
      buffer[1] = '\0';
      return buffer;
    }

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

  p = buffer + sizeof (buffer) - 1;
  *p-- = '\0';

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

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


/* xtoa()-- Integer to hexadecimal conversion.  Returns a pointer to a
 * static buffer. */

char *
xtoa (GFC_UINTEGER_LARGEST n)
{
  int digit;
  char *p;

  if (n == 0)
    {
      buffer[0] = '0';
      buffer[1] = '\0';
      return buffer;
    }

  p = buffer + sizeof (buffer) - 1;
  *p-- = '\0';

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

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

  return ++p;
}


/* st_printf()-- simple printf() function for streams that handles the
 * formats %d, %s and %c.  This function handles printing of error
 * messages that originate within the library itself, not from a user
 * program. */

int
st_printf (const char *format, ...)
{
  int count, total;
  va_list arg;
  char *p, *q;
  stream *s;

  total = 0;
  s = init_error_stream ();
  va_start (arg, format);

  for (;;)
    {
      count = 0;

      while (format[count] != '%' && format[count] != '\0')
	count++;

      if (count != 0)
	{
	  p = salloc_w (s, &count);
	  memmove (p, format, count);
	  sfree (s);
	}

      total += count;
      format += count;
      if (*format++ == '\0')
	break;

      switch (*format)
	{
	case 'c':
	  count = 1;

	  p = salloc_w (s, &count);
	  *p = (char) va_arg (arg, int);

	  sfree (s);
	  break;

	case 'd':
	  q = gfc_itoa (va_arg (arg, int));
	  count = strlen (q);

	  p = salloc_w (s, &count);
	  memmove (p, q, count);
	  sfree (s);
	  break;

	case 'x':
	  q = xtoa (va_arg (arg, unsigned));
	  count = strlen (q);

	  p = salloc_w (s, &count);
	  memmove (p, q, count);
	  sfree (s);
	  break;

	case 's':
	  q = va_arg (arg, char *);
	  count = strlen (q);

	  p = salloc_w (s, &count);
	  memmove (p, q, count);
	  sfree (s);
	  break;

	case '\0':
	  return total;

	default:
	  count = 2;
	  p = salloc_w (s, &count);
	  p[0] = format[-1];
	  p[1] = format[0];
	  sfree (s);
	  break;
	}

      total += count;
      format++;
    }

  va_end (arg);
  return total;
}


/* st_sprintf()-- Simple sprintf() for formatting memory buffers. */

void
st_sprintf (char *buffer, const char *format, ...)
{
  va_list arg;
  char c, *p;
  int count;

  va_start (arg, format);

  for (;;)
    {
      c = *format++;
      if (c != '%')
	{
	  *buffer++ = c;
	  if (c == '\0')
	    break;
	  continue;
	}

      c = *format++;
      switch (c)
	{
	case 'c':
	  *buffer++ = (char) va_arg (arg, int);
	  break;

	case 'd':
	  p = gfc_itoa (va_arg (arg, int));
	  count = strlen (p);

	  memcpy (buffer, p, count);
	  buffer += count;
	  break;

	case 's':
	  p = va_arg (arg, char *);
	  count = strlen (p);

	  memcpy (buffer, p, count);
	  buffer += count;
	  break;

	default:
	  *buffer++ = c;
	}
    }

  va_end (arg);
}


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

void
show_locus (void)
{
  if (!options.locus || filename == NULL)
    return;

  st_printf ("At line %d of file %s\n", line, 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 ();
  show_locus ();
  st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
  sys_exit (1);
}


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

void
runtime_error (const char *message)
{
  recursion_check ();
  show_locus ();
  st_printf ("Fortran runtime error: %s\n", message);
  sys_exit (2);
}
iexport(runtime_error);


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

void
internal_error (const char *message)
{
  recursion_check ();
  show_locus ();
  st_printf ("Internal Error: %s\n", message);
  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 ERROR_EOR:
      p = "End of record";
      break;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    case ERROR_ARRAY_STRIDE:
      p = "Array unit stride must be 1";
      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 (int family, const char *message)
{
  /* Set the error status.  */
  if (ioparm.iostat != NULL)
    *ioparm.iostat = family;

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

  if (ioparm.iomsg)
    cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message);

  /* Report status back to the compiler.  */
  switch (family)
    {
    case ERROR_EOR:
      ioparm.library_return = LIBRARY_EOR;
      if (ioparm.eor != 0)
	return;
      break;

    case ERROR_END:
      ioparm.library_return = LIBRARY_END;
      if (ioparm.end != 0)
	return;
      break;

    default:
      ioparm.library_return = LIBRARY_ERROR;
      if (ioparm.err != 0)
	return;
      break;
    }

  /* Return if the user supplied an iostat variable.  */
  if (ioparm.iostat != NULL)
    return;

  /* Terminate the program */

  runtime_error (message);
}


/* 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 (int std, const char * message)
{
  int warning;

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

  show_locus ();
  if (!warning)
    {
      st_printf ("Fortran runtime error: %s\n", message);
      sys_exit (2);
    }
  else
    st_printf ("Fortran runtime warning: %s\n", message);
  return FAILURE;
}
Commit	Line	Data
999a06a0	1	/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
6de9cd9a DN	2	Contributed by Andy Vaught
6de9cd9a DN	3
57dea9f6	4	This file is part of the GNU Fortran 95 runtime library (libgfortran).
6de9cd9a	5
57dea9f6	6	Libgfortran is free software; you can redistribute it and/or modify
6de9cd9a DN	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
57dea9f6 TM	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,
6de9cd9a DN	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
57dea9f6	26	along with libgfortran; see the file COPYING. If not, write to
fe2ae685 KC	27	the Free Software Foundation, 51 Franklin Street, Fifth Floor,
fe2ae685 KC	28	Boston, MA 02110-1301, USA. */
6de9cd9a DN	29
	30
	31	#include "config.h"
	32	#include <stdio.h>
	33	#include <stdarg.h>
	34	#include <string.h>
	35	#include <float.h>
	36
	37	#include "libgfortran.h"
	38	#include "../io/io.h"
	39
	40	/* Error conditions. The tricky part here is printing a message when
	41	* it is the I/O subsystem that is severely wounded. Our goal is to
	42	* try and print something making the fewest assumptions possible,
	43	* then try to clean up before actually exiting.
	44	*
	45	* The following exit conditions are defined:
	46	* 0 Normal program exit.
	47	* 1 Terminated because of operating system error.
	48	* 2 Error in the runtime library
	49	* 3 Internal error in runtime library
	50	* 4 Error during error processing (very bad)
	51	*
	52	* Other error returns are reserved for the STOP statement with a numeric code.
	53	*/
	54
	55	/* locus variables. These are optionally set by a caller before a
	56	* library subroutine is called. They are always cleared on exit so
	57	* that files that report loci and those that do not can be linked
	58	* together without reporting an erroneous position. */
	59
7d7b8bfe RH	60	char *filename = 0;
	61	iexport_data(filename);
	62
	63	unsigned line = 0;
	64	iexport_data(line);
6de9cd9a	65
999a06a0 TK	66	/* buffer for integer/ascii conversions. */
999a06a0 TK	67	static char buffer[sizeof (GFC_UINTEGER_LARGEST) * 8 + 1];
6de9cd9a	68
6de9cd9a DN	69
	70	/* Returns a pointer to a static buffer. */
	71
	72	char *
32aa3bff	73	gfc_itoa (GFC_INTEGER_LARGEST n)
6de9cd9a DN	74	{
	75	int negative;
	76	char *p;
32aa3bff	77	GFC_UINTEGER_LARGEST t;
6de9cd9a DN	78
	79	if (n == 0)
	80	{
	81	buffer[0] = '0';
	82	buffer[1] = '\0';
	83	return buffer;
	84	}
	85
	86	negative = 0;
5352bda0	87	t = n;
6de9cd9a DN	88	if (n < 0)
	89	{
	90	negative = 1;
5352bda0	91	t = -n; /must use unsigned to protect from overflow/
6de9cd9a DN	92	}
	93
	94	p = buffer + sizeof (buffer) - 1;
	95	*p-- = '\0';
	96
5352bda0	97	while (t != 0)
6de9cd9a	98	{
5352bda0 BD	99	*p-- = '0' + (t % 10);
5352bda0 BD	100	t /= 10;
6de9cd9a DN	101	}
	102
	103	if (negative)
	104	*p-- = '-';
	105	return ++p;
	106	}
	107
	108
	109	/* xtoa()-- Integer to hexadecimal conversion. Returns a pointer to a
	110	* static buffer. */
	111
	112	char *
32aa3bff	113	xtoa (GFC_UINTEGER_LARGEST n)
6de9cd9a DN	114	{
	115	int digit;
	116	char *p;
	117
	118	if (n == 0)
	119	{
	120	buffer[0] = '0';
	121	buffer[1] = '\0';
	122	return buffer;
	123	}
	124
	125	p = buffer + sizeof (buffer) - 1;
	126	*p-- = '\0';
	127
	128	while (n != 0)
	129	{
	130	digit = n & 0xF;
	131	if (digit > 9)
	132	digit += 'A' - '0' - 10;
	133
	134	*p-- = '0' + digit;
	135	n >>= 4;
	136	}
	137
	138	return ++p;
	139	}
	140
	141
	142	/* st_printf()-- simple printf() function for streams that handles the
	143	* formats %d, %s and %c. This function handles printing of error
	144	* messages that originate within the library itself, not from a user
	145	* program. */
	146
	147	int
	148	st_printf (const char *format, ...)
	149	{
	150	int count, total;
	151	va_list arg;
	152	char p, q;
	153	stream *s;
	154
	155	total = 0;
	156	s = init_error_stream ();
	157	va_start (arg, format);
	158
	159	for (;;)
	160	{
	161	count = 0;
	162
	163	while (format[count] != '%' && format[count] != '\0')
	164	count++;
	165
	166	if (count != 0)
	167	{
	168	p = salloc_w (s, &count);
	169	memmove (p, format, count);
	170	sfree (s);
	171	}
	172
	173	total += count;
	174	format += count;
	175	if (*format++ == '\0')
	176	break;
	177
178	switch (*format)
179	{
180	case 'c':
181	count = 1;
182
183	p = salloc_w (s, &count);
184	*p = (char) va_arg (arg, int);
185
186	sfree (s);
187	break;
188
189	case 'd':
9548f059	190	q = gfc_itoa (va_arg (arg, int));
6de9cd9a DN	191	count = strlen (q);
	192
	193	p = salloc_w (s, &count);
	194	memmove (p, q, count);
	195	sfree (s);
	196	break;
	197
	198	case 'x':
	199	q = xtoa (va_arg (arg, unsigned));
	200	count = strlen (q);
	201
	202	p = salloc_w (s, &count);
	203	memmove (p, q, count);
	204	sfree (s);
	205	break;
	206
	207	case 's':
	208	q = va_arg (arg, char *);
	209	count = strlen (q);
	210
	211	p = salloc_w (s, &count);
	212	memmove (p, q, count);
	213	sfree (s);
	214	break;
	215
	216	case '\0':
	217	return total;
	218
	219	default:
	220	count = 2;
	221	p = salloc_w (s, &count);
	222	p[0] = format[-1];
	223	p[1] = format[0];
	224	sfree (s);
	225	break;
	226	}
	227
	228	total += count;
	229	format++;
	230	}
	231
	232	va_end (arg);
	233	return total;
	234	}
	235
	236
	237	/* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
	238
	239	void
	240	st_sprintf (char buffer, const char format, ...)
	241	{
	242	va_list arg;
	243	char c, *p;
	244	int count;
	245
	246	va_start (arg, format);
	247
	248	for (;;)
	249	{
	250	c = *format++;
	251	if (c != '%')
	252	{
	253	*buffer++ = c;
	254	if (c == '\0')
255	break;
256	continue;
257	}
258
259	c = *format++;
260	switch (c)
261	{
262	case 'c':
263	*buffer++ = (char) va_arg (arg, int);
264	break;
265
266	case 'd':
9548f059	267	p = gfc_itoa (va_arg (arg, int));
6de9cd9a DN	268	count = strlen (p);
	269
	270	memcpy (buffer, p, count);
	271	buffer += count;
	272	break;
	273
	274	case 's':
	275	p = va_arg (arg, char *);
	276	count = strlen (p);
	277
	278	memcpy (buffer, p, count);
	279	buffer += count;
	280	break;
	281
	282	default:
	283	*buffer++ = c;
	284	}
	285	}
	286
	287	va_end (arg);
	288	}
	289
	290
	291	/* show_locus()-- Print a line number and filename describing where
	292	* something went wrong */
	293
	294	void
	295	show_locus (void)
	296	{
6de9cd9a DN	297	if (!options.locus \|\| filename == NULL)
	298	return;
	299
	300	st_printf ("At line %d of file %s\n", line, filename);
	301	}
	302
	303
	304	/* recursion_check()-- It's possible for additional errors to occur
	305	* during fatal error processing. We detect this condition here and
	306	* exit with code 4 immediately. */
	307
	308	#define MAGIC 0x20DE8101
	309
	310	static void
	311	recursion_check (void)
	312	{
	313	static int magic = 0;
	314
f21edfd6	315	/* Don't even try to print something at this point */
6de9cd9a	316	if (magic == MAGIC)
f21edfd6	317	sys_exit (4);
6de9cd9a DN	318
	319	magic = MAGIC;
	320	}
	321
	322
	323	/* os_error()-- Operating system error. We get a message from the
	324	* operating system, show it and leave. Some operating system errors
	325	* are caught and processed by the library. If not, we come here. */
	326
	327	void
	328	os_error (const char *message)
	329	{
6de9cd9a	330	recursion_check ();
6de9cd9a DN	331	show_locus ();
6de9cd9a DN	332	st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
6de9cd9a DN	333	sys_exit (1);
	334	}
	335
	336
	337	/* void runtime_error()-- These are errors associated with an
	338	* invalid fortran program. */
	339
	340	void
	341	runtime_error (const char *message)
	342	{
6de9cd9a	343	recursion_check ();
6de9cd9a DN	344	show_locus ();
6de9cd9a DN	345	st_printf ("Fortran runtime error: %s\n", message);
6de9cd9a DN	346	sys_exit (2);
6de9cd9a DN	347	}
7d7b8bfe	348	iexport(runtime_error);
6de9cd9a DN	349
	350
	351	/* void internal_error()-- These are this-can't-happen errors
	352	* that indicate something deeply wrong. */
	353
	354	void
	355	internal_error (const char *message)
	356	{
6de9cd9a	357	recursion_check ();
6de9cd9a DN	358	show_locus ();
	359	st_printf ("Internal Error: %s\n", message);
	360	sys_exit (3);
	361	}
	362
	363
	364	/* translate_error()-- Given an integer error code, return a string
	365	* describing the error. */
	366
	367	const char *
	368	translate_error (int code)
	369	{
	370	const char *p;
	371
	372	switch (code)
	373	{
	374	case ERROR_EOR:
	375	p = "End of record";
	376	break;
	377
	378	case ERROR_END:
	379	p = "End of file";
	380	break;
	381
	382	case ERROR_OK:
	383	p = "Successful return";
	384	break;
	385
	386	case ERROR_OS:
	387	p = "Operating system error";
	388	break;
	389
	390	case ERROR_BAD_OPTION:
	391	p = "Bad statement option";
	392	break;
	393
	394	case ERROR_MISSING_OPTION:
	395	p = "Missing statement option";
	396	break;
	397
	398	case ERROR_OPTION_CONFLICT:
	399	p = "Conflicting statement options";
	400	break;
	401
	402	case ERROR_ALREADY_OPEN:
	403	p = "File already opened in another unit";
	404	break;
	405
	406	case ERROR_BAD_UNIT:
	407	p = "Unattached unit";
	408	break;
	409
	410	case ERROR_FORMAT:
	411	p = "FORMAT error";
	412	break;
	413
	414	case ERROR_BAD_ACTION:
	415	p = "Incorrect ACTION specified";
	416	break;
	417
	418	case ERROR_ENDFILE:
	419	p = "Read past ENDFILE record";
	420	break;
	421
422	case ERROR_BAD_US:
423	p = "Corrupt unformatted sequential file";
424	break;
425
426	case ERROR_READ_VALUE:
427	p = "Bad value during read";
428	break;
429
430	case ERROR_READ_OVERFLOW:
431	p = "Numeric overflow on read";
432	break;
433
59154ed2 JD	434	case ERROR_ARRAY_STRIDE:
	435	p = "Array unit stride must be 1";
	436	break;
	437
6de9cd9a DN	438	default:
	439	p = "Unknown error code";
	440	break;
	441	}
	442
	443	return p;
	444	}
	445
	446
	447	/* generate_error()-- Come here when an error happens. This
7aba8abe TK	448	* subroutine is called if it is possible to continue on after the error.
	449	* If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
	450	* ERR labels are present, we return, otherwise we terminate the program
	451	* after printing a message. The error code is always required but the
6de9cd9a DN	452	* message parameter can be NULL, in which case a string describing
	453	* the most recent operating system error is used. */
	454
	455	void
	456	generate_error (int family, const char *message)
	457	{
244fada7	458	/* Set the error status. */
6de9cd9a	459	if (ioparm.iostat != NULL)
244fada7	460	*ioparm.iostat = family;
6de9cd9a	461
7aba8abe TK	462	if (message == NULL)
	463	message =
	464	(family == ERROR_OS) ? get_oserror () : translate_error (family);
	465
	466	if (ioparm.iomsg)
	467	cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message);
	468
244fada7	469	/* Report status back to the compiler. */
6de9cd9a DN	470	switch (family)
	471	{
	472	case ERROR_EOR:
	473	ioparm.library_return = LIBRARY_EOR;
	474	if (ioparm.eor != 0)
	475	return;
	476	break;
	477
	478	case ERROR_END:
	479	ioparm.library_return = LIBRARY_END;
	480	if (ioparm.end != 0)
	481	return;
	482	break;
	483
	484	default:
	485	ioparm.library_return = LIBRARY_ERROR;
244fada7 PB	486	if (ioparm.err != 0)
244fada7 PB	487	return;
6de9cd9a DN	488	break;
	489	}
	490
244fada7 PB	491	/* Return if the user supplied an iostat variable. */
244fada7 PB	492	if (ioparm.iostat != NULL)
6de9cd9a DN	493	return;
	494
	495	/* Terminate the program */
	496
6de9cd9a DN	497	runtime_error (message);
6de9cd9a DN	498	}
8b67b708 FXC	499
	500
	501
	502	/* Possibly issue a warning/error about use of a nonstandard (or deleted)
	503	feature. An error/warning will be issued if the currently selected
	504	standard does not contain the requested bits. */
	505
	506	try
	507	notify_std (int std, const char * message)
	508	{
	509	int warning;
	510
	511	warning = compile_options.warn_std & std;
	512	if ((compile_options.allow_std & std) != 0 && !warning)
	513	return SUCCESS;
	514
	515	show_locus ();
	516	if (!warning)
	517	{
	518	st_printf ("Fortran runtime error: %s\n", message);
	519	sys_exit (2);
	520	}
	521	else
	522	st_printf ("Fortran runtime warning: %s\n", message);
	523	return FAILURE;
	524	}