mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
469 lines
14 KiB
C
469 lines
14 KiB
C
/* Copyright 1995-1998,2000-2001,2003-2004,2006,2008,2009-2014,2017-2019
|
||
Free Software Foundation, Inc.
|
||
|
||
This file is part of Guile.
|
||
|
||
Guile is free software: you can redistribute it and/or modify it
|
||
under the terms of the GNU Lesser General Public License as published
|
||
by the Free Software Foundation, either version 3 of the License, or
|
||
(at your option) any later version.
|
||
|
||
Guile 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 Lesser General Public
|
||
License for more details.
|
||
|
||
You should have received a copy of the GNU Lesser General Public
|
||
License along with Guile. If not, see
|
||
<https://www.gnu.org/licenses/>. */
|
||
|
||
|
||
|
||
#ifdef HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#include <stdio.h>
|
||
#include <unistdio.h>
|
||
|
||
#include "backtrace.h"
|
||
#include "boolean.h"
|
||
#include "debug.h"
|
||
#include "dynwind.h"
|
||
#include "eq.h"
|
||
#include "eval.h"
|
||
#include "exceptions.h"
|
||
#include "fluids.h"
|
||
#include "gsubr.h"
|
||
#include "init.h"
|
||
#include "list.h"
|
||
#include "modules.h"
|
||
#include "numbers.h"
|
||
#include "pairs.h"
|
||
#include "ports.h"
|
||
#include "private-options.h"
|
||
#include "smob.h"
|
||
#include "stackchk.h"
|
||
#include "stacks.h"
|
||
#include "strings.h"
|
||
#include "symbols.h"
|
||
#include "variable.h"
|
||
#include "vm.h"
|
||
|
||
#include "throw.h"
|
||
|
||
|
||
|
||
|
||
static SCM throw_var;
|
||
|
||
|
||
|
||
|
||
/* TAG is the catch tag. Typically, this is a symbol, but this
|
||
function doesn't actually care about that.
|
||
|
||
BODY is a pointer to a C function which runs the body of the catch;
|
||
this is the code you can throw from. We call it like this:
|
||
BODY (BODY_DATA)
|
||
where:
|
||
BODY_DATA is just the BODY_DATA argument we received; we pass it
|
||
through to BODY as its first argument. The caller can make
|
||
BODY_DATA point to anything useful that BODY might need.
|
||
|
||
HANDLER is a pointer to a C function to deal with a throw to TAG,
|
||
should one occur. We call it like this:
|
||
HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
|
||
where
|
||
HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
|
||
same idea as BODY_DATA above.
|
||
THROWN_TAG is the tag that the user threw to; usually this is
|
||
TAG, but it could be something else if TAG was #t (i.e., a
|
||
catch-all), or the user threw to a jmpbuf.
|
||
THROW_ARGS is the list of arguments the user passed to the THROW
|
||
function, after the tag.
|
||
|
||
BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
|
||
is just a pointer we pass through to HANDLER. We don't actually
|
||
use either of those pointers otherwise ourselves. The idea is
|
||
that, if our caller wants to communicate something to BODY or
|
||
HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
|
||
HANDLER can then use. Think of it as a way to make BODY and
|
||
HANDLER closures, not just functions; MUMBLE_DATA points to the
|
||
enclosed variables.
|
||
|
||
Of course, it's up to the caller to make sure that any data a
|
||
MUMBLE_DATA needs is protected from GC. A common way to do this is
|
||
to make MUMBLE_DATA a pointer to data stored in an automatic
|
||
structure variable; since the collector must scan the stack for
|
||
references anyway, this assures that any references in MUMBLE_DATA
|
||
will be found. */
|
||
|
||
struct scm_catch_data
|
||
{
|
||
SCM tag;
|
||
scm_t_thunk body;
|
||
void *body_data;
|
||
scm_t_catch_handler handler;
|
||
void *handler_data;
|
||
scm_t_catch_handler pre_unwind_handler;
|
||
void *pre_unwind_handler_data;
|
||
SCM pre_unwind_running;
|
||
};
|
||
|
||
static SCM
|
||
catch_post_unwind_handler (void *data, SCM exn)
|
||
{
|
||
struct scm_catch_data *catch_data = data;
|
||
return catch_data->handler (catch_data->handler_data,
|
||
scm_exception_kind (exn),
|
||
scm_exception_args (exn));
|
||
}
|
||
|
||
static SCM
|
||
catch_pre_unwind_handler (void *data, SCM exn)
|
||
{
|
||
struct scm_catch_data *catch_data = data;
|
||
SCM kind = scm_exception_kind (exn);
|
||
SCM args = scm_exception_args (exn);
|
||
if ((scm_is_eq (catch_data->tag, SCM_BOOL_T)
|
||
|| scm_is_eq (kind, catch_data->tag))
|
||
&& scm_is_false (scm_fluid_ref (catch_data->pre_unwind_running))) {
|
||
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
|
||
scm_dynwind_throw_handler ();
|
||
scm_dynwind_fluid (catch_data->pre_unwind_running, SCM_BOOL_T);
|
||
catch_data->pre_unwind_handler (catch_data->pre_unwind_handler_data,
|
||
kind, args);
|
||
scm_dynwind_end ();
|
||
}
|
||
return scm_raise_exception (exn);
|
||
}
|
||
|
||
static SCM
|
||
catch_body (void *data)
|
||
{
|
||
struct scm_catch_data *catch_data = data;
|
||
|
||
if (catch_data->pre_unwind_handler) {
|
||
SCM thunk = scm_c_make_thunk (catch_data->body, catch_data->body_data);
|
||
SCM handler = scm_c_make_exception_handler (catch_pre_unwind_handler, data);
|
||
SCM fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
|
||
catch_data->pre_unwind_running = fluid;
|
||
return scm_with_pre_unwind_exception_handler (handler, thunk);
|
||
}
|
||
|
||
return catch_data->body (catch_data->body_data);
|
||
}
|
||
|
||
SCM
|
||
scm_c_catch (SCM tag,
|
||
scm_t_thunk body, void *body_data,
|
||
scm_t_catch_handler handler, void *handler_data,
|
||
scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data)
|
||
{
|
||
struct scm_catch_data data =
|
||
{ tag, body, body_data, handler, handler_data, pre_unwind_handler,
|
||
pre_unwind_handler_data, SCM_BOOL_F };
|
||
|
||
return scm_c_with_exception_handler (tag, catch_post_unwind_handler, &data,
|
||
catch_body, &data);
|
||
}
|
||
|
||
SCM
|
||
scm_internal_catch (SCM tag,
|
||
scm_t_thunk body, void *body_data,
|
||
scm_t_catch_handler handler, void *handler_data)
|
||
{
|
||
return scm_c_catch (tag,
|
||
body, body_data,
|
||
handler, handler_data,
|
||
NULL, NULL);
|
||
}
|
||
|
||
|
||
SCM
|
||
scm_c_with_throw_handler (SCM tag,
|
||
scm_t_thunk body,
|
||
void *body_data,
|
||
scm_t_catch_handler handler,
|
||
void *handler_data,
|
||
int lazy_catch_p)
|
||
{
|
||
struct scm_catch_data data =
|
||
{ tag, body, body_data, NULL, NULL, handler, handler_data, SCM_BOOL_F };
|
||
|
||
if (lazy_catch_p)
|
||
/* Non-zero lazy_catch_p arguments have been deprecated since
|
||
2010. */
|
||
abort ();
|
||
|
||
return catch_body (&data);
|
||
}
|
||
|
||
static SCM
|
||
call_thunk (void* data)
|
||
{
|
||
return scm_call_0 (PTR2SCM (data));
|
||
}
|
||
|
||
static SCM
|
||
call_handler (void* data, SCM a, SCM b)
|
||
{
|
||
return scm_call_2 (PTR2SCM (data), a, b);
|
||
}
|
||
|
||
SCM
|
||
scm_catch (SCM key, SCM thunk, SCM handler)
|
||
{
|
||
return scm_c_catch (key, call_thunk, SCM2PTR (thunk),
|
||
call_handler, SCM2PTR (handler), NULL, NULL);
|
||
}
|
||
|
||
SCM
|
||
scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
|
||
SCM pre_unwind_handler)
|
||
{
|
||
if (SCM_UNBNDP (pre_unwind_handler))
|
||
return scm_catch (key, thunk, handler);
|
||
|
||
return scm_c_catch (key, call_thunk, SCM2PTR (thunk),
|
||
call_handler, SCM2PTR (handler),
|
||
call_handler, SCM2PTR (pre_unwind_handler));
|
||
}
|
||
|
||
SCM
|
||
scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
|
||
{
|
||
return scm_c_with_throw_handler (key, call_thunk, SCM2PTR (thunk),
|
||
call_handler, SCM2PTR (handler), 0);
|
||
}
|
||
|
||
SCM
|
||
scm_throw (SCM key, SCM args)
|
||
{
|
||
SCM throw = scm_variable_ref (throw_var);
|
||
if (scm_is_false (throw)) {
|
||
static int error_printing_error = 0;
|
||
if (error_printing_error++)
|
||
{
|
||
fprintf (stderr, "Error while printing pre-boot error: %s\n",
|
||
scm_i_symbol_chars (key));
|
||
}
|
||
else
|
||
{
|
||
SCM port = scm_current_error_port ();
|
||
scm_puts ("Pre-boot error; key: ", port);
|
||
scm_write (key, port);
|
||
scm_puts (", args: ", port);
|
||
scm_write (args, port);
|
||
}
|
||
abort ();
|
||
}
|
||
scm_apply_1 (throw, key, args);
|
||
/* Should not be reached. */
|
||
abort ();
|
||
}
|
||
|
||
|
||
|
||
/* Now some support for C bodies and catch handlers */
|
||
|
||
static scm_t_bits tc16_catch_handler;
|
||
|
||
SCM
|
||
scm_i_make_catch_handler (scm_t_catch_handler handler, void *data)
|
||
{
|
||
SCM_RETURN_NEWSMOB2 (tc16_catch_handler, handler, data);
|
||
}
|
||
|
||
static SCM
|
||
apply_catch_handler (SCM clo, SCM args)
|
||
{
|
||
scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
|
||
void *data = (void*)SCM_SMOB_DATA_2 (clo);
|
||
return handler (data, scm_car (args), scm_cdr (args));
|
||
}
|
||
|
||
|
||
/* body and handler functions for use with any of the above catch variants */
|
||
|
||
/* This is a body function you can pass to scm_internal_catch if you
|
||
want the body to be like Scheme's `catch' --- a thunk.
|
||
|
||
BODY_DATA is a pointer to a scm_body_thunk_data structure, which
|
||
contains the Scheme procedure to invoke as the body, and the tag
|
||
we're catching. */
|
||
|
||
SCM
|
||
scm_body_thunk (void *body_data)
|
||
{
|
||
struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
|
||
|
||
return scm_call_0 (c->body_proc);
|
||
}
|
||
|
||
|
||
/* This is a handler function you can pass to scm_internal_catch if
|
||
you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
|
||
applies a handler procedure to (TAG ARGS ...).
|
||
|
||
If the user does a throw to this catch, this function runs a
|
||
handler procedure written in Scheme. HANDLER_DATA is a pointer to
|
||
an SCM variable holding the Scheme procedure object to invoke. It
|
||
ought to be a pointer to an automatic variable (i.e., one living on
|
||
the stack), or the procedure object should be otherwise protected
|
||
from GC. */
|
||
SCM
|
||
scm_handle_by_proc (void *handler_data, SCM tag, SCM throw_args)
|
||
{
|
||
SCM *handler_proc_p = (SCM *) handler_data;
|
||
|
||
return scm_apply_1 (*handler_proc_p, tag, throw_args);
|
||
}
|
||
|
||
/* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
|
||
catches all throws that the handler might emit itself. The handler
|
||
used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
|
||
|
||
struct hbpca_data {
|
||
SCM proc;
|
||
SCM args;
|
||
};
|
||
|
||
static SCM
|
||
hbpca_body (void *body_data)
|
||
{
|
||
struct hbpca_data *data = (struct hbpca_data *)body_data;
|
||
return scm_apply_0 (data->proc, data->args);
|
||
}
|
||
|
||
SCM
|
||
scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args)
|
||
{
|
||
SCM *handler_proc_p = (SCM *) handler_data;
|
||
struct hbpca_data data;
|
||
data.proc = *handler_proc_p;
|
||
data.args = scm_cons (tag, throw_args);
|
||
|
||
return scm_internal_catch (SCM_BOOL_T,
|
||
hbpca_body, &data,
|
||
scm_handle_by_message_noexit, NULL);
|
||
}
|
||
|
||
|
||
static int
|
||
should_print_backtrace (SCM tag, SCM stack)
|
||
{
|
||
return SCM_BACKTRACE_P
|
||
&& scm_is_true (stack)
|
||
&& scm_initialized_p
|
||
/* It's generally not useful to print backtraces for errors reading
|
||
or expanding code in these fallback catch statements. */
|
||
&& !scm_is_eq (tag, scm_from_latin1_symbol ("read-error"))
|
||
&& !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"));
|
||
}
|
||
|
||
static void
|
||
handler_message (void *handler_data, SCM tag, SCM args)
|
||
{
|
||
SCM p, stack, frame;
|
||
|
||
p = scm_current_error_port ();
|
||
/* Usually we get here via a throw to a catch-all. In that case
|
||
there is the throw frame active, and the catch closure, so narrow by
|
||
two frames. It is possible for a user to invoke
|
||
scm_handle_by_message directly, though, so it could be this
|
||
narrows too much. We'll have to see how this works out in
|
||
practice. */
|
||
stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
|
||
frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
|
||
|
||
if (should_print_backtrace (tag, stack))
|
||
{
|
||
scm_puts ("Backtrace:\n", p);
|
||
scm_display_backtrace_with_highlights (stack, p,
|
||
SCM_BOOL_F, SCM_BOOL_F,
|
||
SCM_EOL);
|
||
scm_newline (p);
|
||
}
|
||
|
||
scm_print_exception (p, frame, tag, args);
|
||
}
|
||
|
||
|
||
/* This is a handler function to use if you want scheme to print a
|
||
message and die. Useful for dealing with throws to uncaught keys
|
||
at the top level.
|
||
|
||
At boot time, we establish a catch-all that uses this as its handler.
|
||
1) If the user wants something different, they can use (catch #t
|
||
...) to do what they like.
|
||
2) Outside the context of a read-eval-print loop, there isn't
|
||
anything else good to do; libguile should not assume the existence
|
||
of a read-eval-print loop.
|
||
3) Given that we shouldn't do anything complex, it's much more
|
||
robust to do it in C code.
|
||
|
||
HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
|
||
message header to print; if zero, we use "guile" instead. That
|
||
text is followed by a colon, then the message described by ARGS. */
|
||
|
||
/* Dirk:FIXME:: The name of the function should make clear that the
|
||
* application gets terminated.
|
||
*/
|
||
|
||
SCM
|
||
scm_handle_by_message (void *handler_data, SCM tag, SCM args)
|
||
{
|
||
if (scm_is_true (scm_eq_p (tag, scm_from_latin1_symbol ("quit"))))
|
||
exit (scm_exit_status (args));
|
||
|
||
handler_message (handler_data, tag, args);
|
||
scm_i_pthread_exit (NULL);
|
||
|
||
/* this point not reached, but suppress gcc warning about no return value
|
||
in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
|
||
to be the case on cygwin for instance) */
|
||
return SCM_BOOL_F;
|
||
}
|
||
|
||
|
||
/* This is just like scm_handle_by_message, but it doesn't exit; it
|
||
just returns #f. It's useful in cases where you don't really know
|
||
enough about the body to handle things in a better way, but don't
|
||
want to let throws fall off the bottom of the wind list. */
|
||
SCM
|
||
scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
|
||
{
|
||
if (scm_is_true (scm_eq_p (tag, scm_from_latin1_symbol ("quit"))))
|
||
exit (scm_exit_status (args));
|
||
|
||
handler_message (handler_data, tag, args);
|
||
|
||
return SCM_BOOL_F;
|
||
}
|
||
|
||
|
||
SCM
|
||
scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
|
||
{
|
||
scm_ithrow (tag, args, 1);
|
||
return SCM_UNSPECIFIED; /* never returns */
|
||
}
|
||
|
||
SCM
|
||
scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
|
||
{
|
||
scm_throw (key, args);
|
||
}
|
||
|
||
void
|
||
scm_init_throw ()
|
||
{
|
||
tc16_catch_handler = scm_make_smob_type ("catch-handler", 0);
|
||
scm_set_smob_apply (tc16_catch_handler, apply_catch_handler, 0, 0, 1);
|
||
|
||
throw_var = scm_c_define ("throw", SCM_BOOL_F);
|
||
|
||
#include "throw.x"
|
||
}
|