void
error_stop_string (const char *string, GFC_INTEGER_4 len)
{
estr_write ("ERROR STOP ");
(void) write (STDERR_FILENO, string, len);
estr_write ("\n");
exit (1);
}
void
pause_string (char *string, GFC_INTEGER_4 len)
{
estr_write ("PAUSE ");
ssize_t w = write (STDERR_FILENO, string, len);
(void) sizeof (w); /* Avoid compiler warning about not using write
return val. */
estr_write ("\n");
do_pause ();
}
void
stop_string (const char *string, GFC_INTEGER_4 len)
{
if (string)
{
estr_write ("STOP ");
(void) write (STDERR_FILENO, string, len);
estr_write ("\n");
}
exit (0);
}
static void
do_pause (void)
{
char buff[4];
estr_write ("To resume execution, type go. "
"Other input will terminate the job.\n");
fgets(buff, 4, stdin);
if (strncmp(buff, "go\n", 3) != 0)
stop_string ('\0', 0);
estr_write ("RESUMED\n");
}
static void
show_string (variable * v)
{
const char *p;
p = getenv (v->name);
if (p == NULL)
p = "";
estr_write (var_source (v));
estr_write (" \"");
estr_write (p);
estr_write ("\"\n");
}
void
sys_abort (void)
{
/* If backtracing is enabled, print backtrace and disable signal
handler for ABRT. */
if (options.backtrace == 1
|| (options.backtrace == -1 && compile_options.backtrace == 1))
{
estr_write ("\nProgram aborted. Backtrace:\n");
backtrace ();
signal (SIGABRT, SIG_DFL);
}
abort();
}
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';
estr_write (buffer);
}
/* A signal handler to allow us to output a backtrace. */
void
backtrace_handler (int signum)
{
/* Since this handler is established for more than one kind of signal,
it might still get invoked recursively by delivery of some other kind
of signal. Use a static variable to keep track of that. */
if (fatal_error_in_progress)
raise (signum);
fatal_error_in_progress = 1;
show_signal (signum);
estr_write ("\nBacktrace for this error:\n");
show_backtrace (1);
/* Now reraise the signal. We reactivate the signal's
default handling, which is to terminate the process.
We could just call exit or abort,
but reraising the signal sets the return status
from the process correctly. */
signal (signum, SIG_DFL);
raise (signum);
}
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);
}
void
show_backtrace (void)
{
#if GLIBC_BACKTRACE
#define DEPTH 50
#define BUFSIZE 1024
void *trace[DEPTH];
int depth;
depth = backtrace (trace, DEPTH);
if (depth <= 0)
return;
#if CAN_PIPE
if (addr2line_path == NULL)
goto fallback_noerr;
/* We attempt to extract file and line information from addr2line. */
do
{
/* Local variables. */
int f[2], pid, bt[2], inp[2];
char addr_buf[GFC_XTOA_BUF_SIZE], func[BUFSIZE], file[BUFSIZE];
char *p;
/* 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 (pipe (inp) != 0)
break;
if ((pid = fork ()) == -1)
break;
if (pid == 0)
{
/* Child process. */
#define NUM_FIXEDARGS 7
char *arg[NUM_FIXEDARGS];
char *newenv[] = { NULL };
close (f[0]);
close (inp[1]);
if (dup2 (inp[0], STDIN_FILENO) == -1)
_exit (1);
close (inp[0]);
close (STDERR_FILENO);
if (dup2 (f[1], STDOUT_FILENO) == -1)
_exit (1);
close (f[1]);
arg[0] = addr2line_path;
arg[1] = (char *) "-e";
arg[2] = full_exe_path ();
arg[3] = (char *) "-f";
arg[4] = (char *) "-s";
arg[5] = (char *) "-C";
arg[6] = NULL;
execve (addr2line_path, arg, newenv);
_exit (1);
#undef NUM_FIXEDARGS
}
/* Father process. */
close (f[1]);
close (inp[0]);
if (pipe (bt) != 0)
break;
backtrace_symbols_fd (trace, depth, bt[1]);
close (bt[1]);
estr_write ("\nBacktrace for this error:\n");
for (int j = 0; j < depth; j++)
{
const char *addr = gfc_xtoa
((GFC_UINTEGER_LARGEST) (intptr_t) trace[j],
addr_buf, sizeof (addr_buf));
write (inp[1], addr, strlen (addr));
write (inp[1], "\n", 1);
if (! fd_gets (func, sizeof(func), f[0]))
goto fallback;
if (! fd_gets (file, sizeof(file), f[0]))
goto fallback;
for (p = func; *p != '\n' && *p != '\r'; p++)
;
*p = '\0';
/* If we only have the address, use the glibc backtrace. */
if (func[0] == '?' && func[1] == '?' && file[0] == '?'
&& file[1] == '?')
{
bt_header (j);
while (1)
{
char bc;
ssize_t nread = read (bt[0], &bc, 1);
if (nread != 1 || bc == '\n')
break;
write (STDERR_FILENO, &bc, 1);
}
estr_write ("\n");
continue;
}
else
{
/* Forward to the next entry in the backtrace. */
while (1)
{
char bc;
ssize_t nread = read (bt[0], &bc, 1);
if (nread != 1 || bc == '\n')
break;
}
}
/* _start is a setup routine that calls main(), and main() is
the frontend routine that calls some setup stuff and then
calls MAIN__, so at this point we should stop. */
if (strcmp (func, "_start") == 0 || strcmp (func, "main") == 0)
break;
bt_header (j);
estr_write (full_exe_path ());
estr_write ("[0x");
estr_write (addr);
estr_write ("] in ");
estr_write (func);
if (strncmp (file, "??", 2) == 0)
estr_write ("\n");
else
{
estr_write (" at ");
estr_write (file);
}
} /* Loop over each hex address. */
close (inp[1]);
close (bt[0]);
wait (NULL);
return;
fallback:
estr_write ("** Something went wrong while running addr2line. **\n"
"** Falling back to a simpler backtrace scheme. **\n");
}
while (0);
#undef DEPTH
#undef BUFSIZE
#endif /* CAN_PIPE */
fallback_noerr:
/* Fallback to the glibc backtrace. */
estr_write ("\nBacktrace for this error:\n");
backtrace_symbols_fd (trace, depth, STDERR_FILENO);
return;
#elif defined(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];
estr_write ("\nBacktrace for this error:\n");
arg[0] = (char *) "pstack";
snprintf (buf, sizeof(buf), "%d", (int) getppid ());
arg[1] = buf;
arg[2] = NULL;
execvp (arg[0], arg);
#undef NUM_ARGS
/* pstack didn't work. */
estr_write (" unable to produce a backtrace, sorry!\n");
_exit (1);
}
/* Father process. */
wait (NULL);
return;
}
while(0);
#else
estr_write ("\nBacktrace not yet available on this platform, sorry!\n");
#endif
}