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);
}
void
stop_string (const char *string, GFC_INTEGER_4 len)
{
show_locus ();
st_printf ("STOP ");
while (len--)
st_printf ("%c", *(string++));
st_printf ("\n");
sys_exit (0);
}
/* A numeric or blank STOP statement. */
void
stop_numeric (GFC_INTEGER_4 code)
{
show_locus ();
if (code == -1)
code = 0;
else
st_printf ("STOP %d\n", (int)code);
sys_exit (code);
}
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);
}
