void
dump_format (void)
{
st_printf ("format = ");
dump_format0 (&array[0]);
st_printf ("\n");
}
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);
}
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 (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);
}
void
stop_string (const char *string, GFC_INTEGER_4 len)
{
st_printf ("STOP ");
while (len--)
st_printf ("%c", *(string++));
st_printf ("\n");
sys_exit (0);
}
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");
}
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);
}
static void
show_mem (variable * v)
{
char *p;
p = getenv (v->name);
st_printf ("%s ", var_source (v));
if (options.allocate_init_flag)
st_printf ("0x%x", options.allocate_init_value);
st_printf ("\n");
}
static void
show_choice (variable * v, const choice * c)
{
st_printf ("%s ", var_source (v));
for (; c->name; c++)
if (c->value == *v->var)
break;
if (c->name)
st_printf ("%s\n", c->name);
else
st_printf ("(Unknown)\n");
}
void
os_error (const char *message)
{
recursion_check ();
st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
sys_exit (1);
}
void
show_variables (void)
{
variable *v;
int n;
/* TODO: print version number. */
estr_write ("GNU Fortran runtime library version "
"UNKNOWN" "\n\n");
estr_write ("Environment variables:\n");
estr_write ("----------------------\n");
for (v = variable_table; v->name; v++)
{
n = estr_write (v->name);
print_spaces (25 - n);
if (v->show == show_integer)
estr_write ("Integer ");
else if (v->show == show_boolean)
estr_write ("Boolean ");
else
estr_write ("String ");
v->show (v);
estr_write (v->desc);
estr_write ("\n\n");
}
/* System error codes */
estr_write ("\nRuntime error codes:");
estr_write ("\n--------------------\n");
for (n = LIBERROR_FIRST + 1; n < LIBERROR_LAST; n++)
if (n < 0 || n > 9)
st_printf ("%d %s\n", n, translate_error (n));
else
st_printf (" %d %s\n", n, translate_error (n));
estr_write ("\nCommand line arguments:\n");
estr_write (" --help Print this list\n");
exit (0);
}
int ksprintf(char *s,char *format,...)
{
unsigned int *vargs;
asm("mov %%ebp,%0":"=m" (vargs):);
vargs+=4;
return st_printf(s,-1,format,vargs);
}
int kfprintf(int fl,char *format,...)
{
unsigned int *vargs;
asm("mov %%ebp,%0":"=m" (vargs):);
vargs+=4;
return st_printf(0,fl,format,vargs);
}
void
next_test (void)
{
fnode *f;
int i;
for (i = 0; i < 20; i++)
{
f = next_format ();
if (f == NULL)
{
st_printf ("No format!\n");
break;
}
dump_format1 (f);
st_printf ("\n");
}
}
static void
dump_glibc_backtrace (int depth, char *str[])
{
int i;
for (i = 0; i < depth; i++)
st_printf (" + %s\n", str[i]);
free (str);
}
/* A numeric or blank STOP statement. */
void
stop_numeric (GFC_INTEGER_4 code)
{
if (code == -1)
code = 0;
else
st_printf ("STOP %d\n", (int)code);
sys_exit (code);
}
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);
}
static void
show_string (variable * v)
{
const char *p;
p = getenv (v->name);
if (p == NULL)
p = "";
st_printf ("%s \"%s\"\n", var_source (v), p);
}
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);
}
static void
print_spaces (int n)
{
char buffer[80];
int i;
if (n <= 0)
return;
for (i = 0; i < n; i++)
buffer[i] = ' ';
buffer[i] = '\0';
st_printf (buffer);
}
void
show_variables (void)
{
variable *v;
int n;
/* TODO: print version number. */
st_printf ("GNU Fortran 95 runtime library version "
"UNKNOWN" "\n\n");
st_printf ("Environment variables:\n");
st_printf ("----------------------\n");
for (v = variable_table; v->name; v++)
{
n = st_printf ("%s", v->name);
print_spaces (25 - n);
if (v->show == show_integer)
st_printf ("Integer ");
else if (v->show == show_boolean)
st_printf ("Boolean ");
else
st_printf ("String ");
v->show (v);
st_printf ("%s\n\n", v->desc);
}
/* System error codes */
st_printf ("\nRuntime error codes:");
st_printf ("\n--------------------\n");
for (n = ERROR_FIRST + 1; n < ERROR_LAST; n++)
if (n < 0 || n > 9)
st_printf ("%d %s\n", n, translate_error (n));
else
st_printf (" %d %s\n", n, translate_error (n));
st_printf ("\nCommand line arguments:\n");
st_printf (" --help Print this list\n");
/* st_printf(" --resume <dropfile> Resume program execution from dropfile\n"); */
sys_exit (0);
}
/* show_backtrace displays the backtrace, currently obtained by means of
the glibc backtrace* functions. */
void
show_backtrace (void)
{
#if GLIBC_BACKTRACE
#define DEPTH 50
#define BUFSIZE 1024
void *trace[DEPTH];
char **str;
int depth;
depth = backtrace (trace, DEPTH);
if (depth <= 0)
return;
str = backtrace_symbols (trace, depth);
#if CAN_PIPE
#ifndef STDIN_FILENO
#define STDIN_FILENO 0
#endif
#ifndef STDOUT_FILENO
#define STDOUT_FILENO 1
#endif
#ifndef STDERR_FILENO
#define STDERR_FILENO 2
#endif
/* We attempt to extract file and line information from addr2line. */
do
{
/* Local variables. */
int f[2], pid, line, i;
FILE *output;
char addr_buf[DEPTH][GFC_XTOA_BUF_SIZE], func[BUFSIZE], file[BUFSIZE];
char *p, *end;
const char *addr[DEPTH];
/* Write the list of addresses in hexadecimal format. */
for (i = 0; i < depth; i++)
addr[i] = xtoa ((GFC_UINTEGER_LARGEST) (intptr_t) trace[i], addr_buf[i],
sizeof (addr_buf[i]));
/* Don't output an error message if something goes wrong, we'll simply
fall back to the pstack and glibc backtraces. */
if (pipe (f) != 0)
break;
if ((pid = fork ()) == -1)
break;
if (pid == 0)
{
/* Child process. */
#define NUM_FIXEDARGS 5
char *arg[DEPTH+NUM_FIXEDARGS+1];
close (f[0]);
close (STDIN_FILENO);
close (STDERR_FILENO);
if (dup2 (f[1], STDOUT_FILENO) == -1)
_exit (0);
close (f[1]);
arg[0] = (char *) "addr2line";
arg[1] = (char *) "-e";
arg[2] = full_exe_path ();
arg[3] = (char *) "-f";
arg[4] = (char *) "-s";
for (i = 0; i < depth; i++)
arg[NUM_FIXEDARGS+i] = (char *) addr[i];
arg[NUM_FIXEDARGS+depth] = NULL;
execvp (arg[0], arg);
_exit (0);
#undef NUM_FIXEDARGS
}
/* Father process. */
close (f[1]);
wait (NULL);
output = fdopen (f[0], "r");
i = -1;
if (fgets (func, sizeof(func), output))
{
st_printf ("\nBacktrace for this error:\n");
do
{
if (! fgets (file, sizeof(file), output))
goto fallback;
i++;
for (p = func; *p != '\n' && *p != '\r'; p++)
;
*p = '\0';
/* Try to recognize the internal libgfortran functions. */
if (strncasecmp (func, "*_gfortran", 10) == 0
|| strncasecmp (func, "_gfortran", 9) == 0
|| strcmp (func, "main") == 0 || strcmp (func, "_start") == 0
|| strcmp (func, "_gfortrani_handler") == 0)
continue;
if (local_strcasestr (str[i], "libgfortran.so") != NULL
|| local_strcasestr (str[i], "libgfortran.dylib") != NULL
|| local_strcasestr (str[i], "libgfortran.a") != NULL)
continue;
/* If we only have the address, use the glibc backtrace. */
if (func[0] == '?' && func[1] == '?' && file[0] == '?'
&& file[1] == '?')
{
st_printf (" + %s\n", str[i]);
continue;
}
/* Extract the line number. */
for (end = NULL, p = file; *p; p++)
if (*p == ':')
end = p;
if (end != NULL)
{
*end = '\0';
line = atoi (++end);
}
else
line = -1;
if (strcmp (func, "MAIN__") == 0)
st_printf (" + in the main program\n");
else
st_printf (" + function %s (0x%s)\n", func, addr[i]);
if (line <= 0 && strcmp (file, "??") == 0)
continue;
if (line <= 0)
st_printf (" from file %s\n", file);
else
st_printf (" at line %d of file %s\n", line, file);
}
while (fgets (func, sizeof(func), output));
free (str);
return;
fallback:
st_printf ("** Something went wrong while running addr2line. **\n"
"** Falling back to a simpler backtrace scheme. **\n");
}
}
while (0);
#undef DEPTH
#undef BUFSIZE
#endif
#endif
#if CAN_FORK && defined(HAVE_GETPPID)
/* Try to call pstack. */
do
{
/* Local variables. */
int pid;
/* Don't output an error message if something goes wrong, we'll simply
fall back to the pstack and glibc backtraces. */
if ((pid = fork ()) == -1)
break;
if (pid == 0)
{
/* Child process. */
#define NUM_ARGS 2
char *arg[NUM_ARGS+1];
char buf[20];
st_printf ("\nBacktrace for this error:\n");
arg[0] = (char *) "pstack";
#ifdef HAVE_SNPRINTF
snprintf (buf, sizeof(buf), "%d", (int) getppid ());
#else
sprintf (buf, "%d", (int) getppid ());
#endif
arg[1] = buf;
arg[2] = NULL;
execvp (arg[0], arg);
#undef NUM_ARGS
/* pstack didn't work, so we fall back to dumping the glibc
backtrace if we can. */
#if GLIBC_BACKTRACE
dump_glibc_backtrace (depth, str);
#else
st_printf (" unable to produce a backtrace, sorry!\n");
#endif
_exit (0);
}
/* Father process. */
wait (NULL);
return;
}
while(0);
#endif
#if GLIBC_BACKTRACE
/* Fallback to the glibc backtrace. */
st_printf ("\nBacktrace for this error:\n");
dump_glibc_backtrace (depth, str);
#endif
}
void
dump_format0 (fnode * f)
{
char *p;
int i;
switch (f->format)
{
case FMT_COLON:
st_printf (" :");
break;
case FMT_SLASH:
st_printf (" %d/", f->u.r);
break;
case FMT_DOLLAR:
st_printf (" $");
break;
case FMT_T:
st_printf (" T%d", f->u.n);
break;
case FMT_TR:
st_printf (" TR%d", f->u.n);
break;
case FMT_TL:
st_printf (" TL%d", f->u.n);
break;
case FMT_X:
st_printf (" %dX", f->u.n);
break;
case FMT_S:
st_printf (" S");
break;
case FMT_SS:
st_printf (" SS");
break;
case FMT_SP:
st_printf (" SP");
break;
case FMT_LPAREN:
if (f->repeat == 1)
st_printf (" (");
else
st_printf (" %d(", f->repeat);
dump_format1 (f->u.child);
st_printf (" )");
break;
case FMT_STRING:
st_printf (" '");
p = f->u.string.p;
for (i = f->u.string.length; i > 0; i--)
st_printf ("%c", *p++);
st_printf ("'");
break;
case FMT_P:
st_printf (" %dP", f->u.k);
break;
case FMT_I:
st_printf (" %dI%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
break;
case FMT_B:
st_printf (" %dB%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
break;
case FMT_O:
st_printf (" %dO%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
break;
case FMT_Z:
st_printf (" %dZ%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
break;
case FMT_BN:
st_printf (" BN");
break;
case FMT_BZ:
st_printf (" BZ");
break;
case FMT_D:
st_printf (" %dD%d.%d", f->repeat, f->u.real.w, f->u.real.d);
break;
case FMT_EN:
st_printf (" %dEN%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
f->u.real.e);
break;
case FMT_ES:
st_printf (" %dES%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
f->u.real.e);
break;
case FMT_F:
st_printf (" %dF%d.%d", f->repeat, f->u.real.w, f->u.real.d);
break;
case FMT_E:
st_printf (" %dE%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
f->u.real.e);
break;
case FMT_G:
st_printf (" %dG%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
f->u.real.e);
break;
case FMT_L:
st_printf (" %dL%d", f->repeat, f->u.w);
break;
case FMT_A:
st_printf (" %dA%d", f->repeat, f->u.w);
break;
default:
st_printf (" ???");
break;
}
}
static void
show_sep (variable * v)
{
st_printf ("%s \"%s\"\n", var_source (v), options.separator);
}
static void
show_boolean (variable * v)
{
st_printf ("%s %s\n", var_source (v), *v->var ? "Yes" : "No");
}
static void
show_integer (variable * v)
{
st_printf ("%s %d\n", var_source (v), *v->var);
}
void
stop_numeric_f08 (GFC_INTEGER_4 code)
{
st_printf ("STOP %d\n", (int)code);
exit (code);
}
static void
bt_header (int num)
{
st_printf (" #%d ", num);
}
/* Helper function for backtrace_handler to write information about the
received signal to stderr before actually giving the backtrace. */
static void
show_signal (int signum)
{
const char * name = NULL, * desc = NULL;
switch (signum)
{
#if defined(SIGQUIT)
case SIGQUIT:
name = "SIGQUIT";
desc = "Terminal quit signal";
break;
#endif
/* The following 4 signals are defined by C89. */
case SIGILL:
name = "SIGILL";
desc = "Illegal instruction";
break;
case SIGABRT:
name = "SIGABRT";
desc = "Process abort signal";
break;
case SIGFPE:
name = "SIGFPE";
desc = "Floating-point exception - erroneous arithmetic operation";
break;
case SIGSEGV:
name = "SIGSEGV";
desc = "Segmentation fault - invalid memory reference";
break;
#if defined(SIGBUS)
case SIGBUS:
name = "SIGBUS";
desc = "Access to an undefined portion of a memory object";
break;
#endif
#if defined(SIGSYS)
case SIGSYS:
name = "SIGSYS";
desc = "Bad system call";
break;
#endif
#if defined(SIGTRAP)
case SIGTRAP:
name = "SIGTRAP";
desc = "Trace/breakpoint trap";
break;
#endif
#if defined(SIGXCPU)
case SIGXCPU:
name = "SIGXCPU";
desc = "CPU time limit exceeded";
break;
#endif
#if defined(SIGXFSZ)
case SIGXFSZ:
name = "SIGXFSZ";
desc = "File size limit exceeded";
break;
#endif
}
if (name)
st_printf ("\nProgram received signal %s: %s.\n", name, desc);
else
st_printf ("\nProgram received signal %d.\n", signum);
}
void
pause_numeric (GFC_INTEGER_4 code)
{
st_printf ("PAUSE %d\n", (int) code);
do_pause ();
}
void
error_stop_numeric (GFC_INTEGER_4 code)
{
st_printf ("ERROR STOP %d\n", (int) code);
exit (code);
}
