-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 Free Software Foundation, Inc.
- *
- * This library 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 2.1 of the License, or (at your option) any later version.
- *
- * This library 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 this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- */
-
-
-\f
-
-#include <stdio.h>
-#include "libguile/_scm.h"
-#include "libguile/smob.h"
-#include "libguile/alist.h"
-#include "libguile/eval.h"
-#include "libguile/eq.h"
-#include "libguile/dynwind.h"
-#include "libguile/backtrace.h"
-#include "libguile/debug.h"
-#include "libguile/continuations.h"
-#include "libguile/stackchk.h"
-#include "libguile/stacks.h"
-#include "libguile/fluids.h"
-#include "libguile/ports.h"
-#include "libguile/lang.h"
-
-#include "libguile/validate.h"
-#include "libguile/throw.h"
-
-\f
-/* the jump buffer data structure */
-static scm_t_bits tc16_jmpbuffer;
-
-#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
-
-#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
-#define ACTIVATEJB(x) \
- (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
-#define DEACTIVATEJB(x) \
- (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
-
-#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
-#define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
-#define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
-#define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
-
-static int
-jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#<jmpbuffer ", port);
- scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
- scm_intprint((long) JBJMPBUF (exp), 16, port);
- scm_putc ('>', port);
- return 1 ;
-}
-
-static SCM
-make_jmpbuf (void)
-{
- SCM answer;
- SCM_REDEFER_INTS;
- {
- SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
- SETJBJMPBUF(answer, (jmp_buf *)0);
- DEACTIVATEJB(answer);
- }
- SCM_REALLOW_INTS;
- return answer;
-}
-
-\f
-/* scm_internal_catch (the guts of catch) */
-
-struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
-{
- jmp_buf buf; /* must be first */
- SCM throw_tag;
- SCM retval;
-};
-
-
-/* scm_internal_catch is the guts of catch. It handles all the
- mechanics of setting up a catch target, invoking the catch body,
- and perhaps invoking the handler if the body does a throw.
-
- The function is designed to be usable from C code, but is general
- enough to implement all the semantics Guile Scheme expects from
- throw.
-
- 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. */
-
-SCM
-scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
-{
- struct jmp_buf_and_retval jbr;
- SCM jmpbuf;
- SCM answer;
-
- jmpbuf = make_jmpbuf ();
- answer = SCM_EOL;
- scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
- SETJBJMPBUF(jmpbuf, &jbr.buf);
- SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
- if (setjmp (jbr.buf))
- {
- SCM throw_tag;
- SCM throw_args;
-
-#ifdef STACK_CHECKING
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
- SCM_REDEFER_INTS;
- DEACTIVATEJB (jmpbuf);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
- throw_args = jbr.retval;
- throw_tag = jbr.throw_tag;
- jbr.throw_tag = SCM_EOL;
- jbr.retval = SCM_EOL;
- answer = handler (handler_data, throw_tag, throw_args);
- }
- else
- {
- ACTIVATEJB (jmpbuf);
- answer = body (body_data);
- SCM_REDEFER_INTS;
- DEACTIVATEJB (jmpbuf);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
- }
- return answer;
-}
-
-
-\f
-/* scm_internal_lazy_catch (the guts of lazy catching) */
-
-/* The smob tag for lazy_catch smobs. */
-static scm_t_bits tc16_lazy_catch;
-
-/* This is the structure we put on the wind list for a lazy catch. It
- stores the handler function to call, and the data pointer to pass
- through to it. It's not a Scheme closure, but it is a function
- with data, so the term "closure" is appropriate in its broader
- sense.
-
- (We don't need anything like this in the "eager" catch code,
- because the same C frame runs both the body and the handler.) */
-struct lazy_catch {
- scm_t_catch_handler handler;
- void *handler_data;
-};
-
-/* Strictly speaking, we could just pass a zero for our print
- function, because we don't need to print them. They should never
- appear in normal data structures, only in the wind list. However,
- it might be nice for debugging someday... */
-static int
-lazy_catch_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (closure);
- char buf[200];
-
- sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>",
- (long) c->handler, (long) c->handler_data);
- scm_puts (buf, port);
-
- return 1;
-}
-
-
-/* Given a pointer to a lazy catch structure, return a smob for it,
- suitable for inclusion in the wind list. ("Ah yes, a Château
- Gollombiere '72, non?"). */
-static SCM
-make_lazy_catch (struct lazy_catch *c)
-{
- SCM_RETURN_NEWSMOB (tc16_lazy_catch, c);
-}
-
-#define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
-
-
-/* Exactly like scm_internal_catch, except:
- - It does not unwind the stack (this is the major difference).
- - The handler is not allowed to return. */
-SCM
-scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
-{
- SCM lazy_catch, answer;
- struct lazy_catch c;
-
- c.handler = handler;
- c.handler_data = handler_data;
- lazy_catch = make_lazy_catch (&c);
-
- SCM_REDEFER_INTS;
- scm_dynwinds = scm_acons (tag, lazy_catch, scm_dynwinds);
- SCM_REALLOW_INTS;
-
- answer = (*body) (body_data);
-
- SCM_REDEFER_INTS;
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
-
- return answer;
-}
-
-\f
-/* scm_internal_stack_catch
- Use this one if you want debugging information to be stored in
- scm_the_last_stack_fluid_var on error. */
-
-static SCM
-ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
-{
- /* Save the stack */
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var),
- scm_make_stack (SCM_BOOL_T, SCM_EOL));
- /* Throw the error */
- return scm_throw (tag, throw_args);
-}
-
-struct cwss_data
-{
- SCM tag;
- scm_t_catch_body body;
- void *data;
-};
-
-static SCM
-cwss_body (void *data)
-{
- struct cwss_data *d = data;
- return scm_internal_lazy_catch (d->tag, d->body, d->data, ss_handler, NULL);
-}
-
-SCM
-scm_internal_stack_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data)
-{
- struct cwss_data d;
- d.tag = tag;
- d.body = body;
- d.data = body_data;
- return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
-}
-
-
-\f
-/* 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);
-}
-
-/* Derive the an exit status from the arguments to (quit ...). */
-int
-scm_exit_status (SCM args)
-{
- if (!SCM_NULL_OR_NIL_P (args))
- {
- SCM cqa = SCM_CAR (args);
-
- if (scm_is_integer (cqa))
- return (scm_to_int (cqa));
- else if (scm_is_false (cqa))
- return 1;
- }
- return 0;
-}
-
-
-static void
-handler_message (void *handler_data, SCM tag, SCM args)
-{
- char *prog_name = (char *) handler_data;
- SCM p = scm_cur_errp;
-
- if (scm_ilength (args) >= 3)
- {
- SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
- SCM subr = SCM_CAR (args);
- SCM message = SCM_CADR (args);
- SCM parts = SCM_CADDR (args);
- SCM rest = SCM_CDDDR (args);
-
- if (SCM_BACKTRACE_P && scm_is_true (stack))
- {
- scm_puts ("Backtrace:\n", p);
- scm_display_backtrace (stack, p, SCM_UNDEFINED, SCM_UNDEFINED);
- scm_newline (p);
- }
- scm_i_display_error (stack, p, subr, message, parts, rest);
- }
- else
- {
- if (! prog_name)
- prog_name = "guile";
-
- scm_puts (prog_name, p);
- scm_puts (": ", p);
-
- scm_puts ("uncaught throw to ", p);
- scm_prin1 (tag, p, 0);
- scm_puts (": ", p);
- scm_prin1 (args, p, 1);
- scm_putc ('\n', p);
- }
-}
-
-
-/* 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_locale_symbol ("quit"))))
- {
- exit (scm_exit_status (args));
- }
-
- handler_message (handler_data, tag, args);
- exit (2);
-}
-
-
-/* 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)
-{
- 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 */
-}
-
-
-\f
-/* the Scheme-visible CATCH and LAZY-CATCH functions */
-
-SCM_DEFINE (scm_catch, "catch", 3, 0, 0,
- (SCM key, SCM thunk, SCM handler),
- "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
- "exceptions matching @var{key}. If thunk throws to the symbol\n"
- "@var{key}, then @var{handler} is invoked this way:\n"
- "@lisp\n"
- "(handler key args ...)\n"
- "@end lisp\n"
- "\n"
- "@var{key} is a symbol or @code{#t}.\n"
- "\n"
- "@var{thunk} takes no arguments. If @var{thunk} returns\n"
- "normally, that is the return value of @code{catch}.\n"
- "\n"
- "Handler is invoked outside the scope of its own @code{catch}.\n"
- "If @var{handler} again throws to the same key, a new handler\n"
- "from further up the call chain is invoked.\n"
- "\n"
- "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
- "match this call to @code{catch}.")
-#define FUNC_NAME s_scm_catch
-{
- struct scm_body_thunk_data c;
-
- SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
- key, SCM_ARG1, FUNC_NAME);
-
- c.tag = key;
- c.body_proc = thunk;
-
- /* scm_internal_catch takes care of all the mechanics of setting up
- a catch key; we tell it to call scm_body_thunk to run the body,
- and scm_handle_by_proc to deal with any throws to this catch.
- The former receives a pointer to c, telling it how to behave.
- The latter receives a pointer to HANDLER, so it knows who to call. */
- return scm_internal_catch (key,
- scm_body_thunk, &c,
- scm_handle_by_proc, &handler);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
- (SCM key, SCM thunk, SCM handler),
- "This behaves exactly like @code{catch}, except that it does\n"
- "not unwind the stack before invoking @var{handler}.\n"
- "The @var{handler} procedure is not allowed to return:\n"
- "it must throw to another catch, or otherwise exit non-locally.")
-#define FUNC_NAME s_scm_lazy_catch
-{
- struct scm_body_thunk_data c;
-
- SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
- key, SCM_ARG1, FUNC_NAME);
-
- c.tag = key;
- c.body_proc = thunk;
-
- /* scm_internal_lazy_catch takes care of all the mechanics of
- setting up a lazy catch key; we tell it to call scm_body_thunk to
- run the body, and scm_handle_by_proc to deal with any throws to
- this catch. The former receives a pointer to c, telling it how
- to behave. The latter receives a pointer to HANDLER, so it knows
- who to call. */
- return scm_internal_lazy_catch (key,
- scm_body_thunk, &c,
- scm_handle_by_proc, &handler);
-}
-#undef FUNC_NAME
-
-
-\f
-/* throwing */
-
-SCM_DEFINE (scm_throw, "throw", 1, 0, 1,
- (SCM key, SCM args),
- "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
- "@var{handler}. \n\n"
- "@var{key} is a symbol. It will match catches of the same symbol or of\n"
- "@code{#t}.\n\n"
- "If there is no handler at all, Guile prints an error and then exits.")
-#define FUNC_NAME s_scm_throw
-{
- SCM_VALIDATE_SYMBOL (1, key);
- return scm_ithrow (key, args, 1);
-}
-#undef FUNC_NAME
-
-SCM
-scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
-{
- SCM jmpbuf = SCM_UNDEFINED;
- SCM wind_goal;
-
- SCM dynpair = SCM_UNDEFINED;
- SCM winds;
-
- /* Search the wind list for an appropriate catch.
- "Waiter, please bring us the wind list." */
- for (winds = scm_dynwinds; scm_is_pair (winds); winds = SCM_CDR (winds))
- {
- dynpair = SCM_CAR (winds);
- if (scm_is_pair (dynpair))
- {
- SCM this_key = SCM_CAR (dynpair);
-
- if (scm_is_eq (this_key, SCM_BOOL_T) || scm_is_eq (this_key, key))
- break;
- }
- }
-
- /* If we didn't find anything, print a message and abort the process
- right here. If you don't want this, establish a catch-all around
- any code that might throw up. */
- if (scm_is_null (winds))
- {
- scm_handle_by_message (NULL, key, args);
- abort ();
- }
-
- /* If the wind list is malformed, bail. */
- if (!scm_is_pair (winds))
- abort ();
-
- jmpbuf = SCM_CDR (dynpair);
-
- for (wind_goal = scm_dynwinds;
- !scm_is_eq (SCM_CDAR (wind_goal), jmpbuf);
- wind_goal = SCM_CDR (wind_goal))
- ;
-
- /* Is a lazy catch? In wind list entries for lazy catches, the key
- is bound to a lazy_catch smob, not a jmpbuf. */
- if (SCM_LAZY_CATCH_P (jmpbuf))
- {
- struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (jmpbuf);
- SCM handle, answer;
- scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
- - scm_ilength (wind_goal)));
- SCM_REDEFER_INTS;
- handle = scm_dynwinds;
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
- answer = (c->handler) (c->handler_data, key, args);
- scm_misc_error ("throw", "lazy-catch handler did return.", SCM_EOL);
- }
-
- /* Otherwise, it's a normal catch. */
- else if (SCM_JMPBUFP (jmpbuf))
- {
- struct jmp_buf_and_retval * jbr;
- scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
- - scm_ilength (wind_goal)));
- jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
- jbr->throw_tag = key;
- jbr->retval = args;
- scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
- longjmp (*JBJMPBUF (jmpbuf), 1);
- }
-
- /* Otherwise, it's some random piece of junk. */
- else
- abort ();
-}
-
-
-void
-scm_init_throw ()
-{
- tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0);
- scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print);
-
- tc16_lazy_catch = scm_make_smob_type ("lazy-catch", 0);
- scm_set_smob_print (tc16_lazy_catch, lazy_catch_print);
-
-#include "libguile/throw.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ *
+ * This library 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.
+ *
+ * This library 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 this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <unistdio.h>
+#include "libguile/_scm.h"
+#include "libguile/smob.h"
+#include "libguile/eval.h"
+#include "libguile/eq.h"
+#include "libguile/control.h"
+#include "libguile/deprecation.h"
+#include "libguile/backtrace.h"
+#include "libguile/debug.h"
+#include "libguile/stackchk.h"
+#include "libguile/stacks.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
+#include "libguile/validate.h"
+#include "libguile/vm.h"
+#include "libguile/throw.h"
+#include "libguile/init.h"
+#include "libguile/strings.h"
+
+#include "libguile/private-options.h"
+
+
+/* Pleasantly enough, the guts of catch are defined in Scheme, in terms of
+ prompt, abort, and the %exception-handler fluid. This file just provides
+ shims so that it's easy to have catch functionality from C.
+
+ All of these function names and prototypes carry a fair bit of historical
+ baggage. */
+
+
+\f
+
+static SCM catch_var, throw_var, with_throw_handler_var;
+
+SCM
+scm_catch (SCM key, SCM thunk, SCM handler)
+{
+ return scm_call_3 (scm_variable_ref (catch_var), key, thunk, handler);
+}
+
+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);
+ else
+ return scm_call_4 (scm_variable_ref (catch_var), key, thunk, handler,
+ pre_unwind_handler);
+}
+
+static void
+init_with_throw_handler_var (void)
+{
+ with_throw_handler_var
+ = scm_module_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("with-throw-handler"));
+}
+
+SCM
+scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
+{
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_with_throw_handler_var);
+
+ return scm_call_3 (scm_variable_ref (with_throw_handler_var),
+ key, thunk, handler);
+}
+
+SCM
+scm_throw (SCM key, SCM args)
+{
+ return scm_apply_1 (scm_variable_ref (throw_var), key, args);
+}
+
+\f
+
+/* Now some support for C bodies and catch handlers */
+
+static scm_t_bits tc16_catch_closure;
+
+enum {
+ CATCH_CLOSURE_BODY,
+ CATCH_CLOSURE_HANDLER
+};
+
+static SCM
+make_catch_body_closure (scm_t_catch_body body, void *body_data)
+{
+ SCM ret;
+ SCM_NEWSMOB2 (ret, tc16_catch_closure, body, body_data);
+ SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_BODY);
+ return ret;
+}
+
+static SCM
+make_catch_handler_closure (scm_t_catch_handler handler, void *handler_data)
+{
+ SCM ret;
+ SCM_NEWSMOB2 (ret, tc16_catch_closure, handler, handler_data);
+ SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_HANDLER);
+ return ret;
+}
+
+static SCM
+apply_catch_closure (SCM clo, SCM args)
+{
+ void *data = (void*)SCM_SMOB_DATA_2 (clo);
+
+ switch (SCM_SMOB_FLAGS (clo))
+ {
+ case CATCH_CLOSURE_BODY:
+ {
+ scm_t_catch_body body = (void*)SCM_SMOB_DATA (clo);
+ return body (data);
+ }
+ case CATCH_CLOSURE_HANDLER:
+ {
+ scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
+ return handler (data, scm_car (args), scm_cdr (args));
+ }
+ default:
+ abort ();
+ }
+}
+
+/* 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. */
+
+SCM
+scm_c_catch (SCM tag,
+ scm_t_catch_body 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 sbody, shandler, spre_unwind_handler;
+
+ sbody = make_catch_body_closure (body, body_data);
+ shandler = make_catch_handler_closure (handler, handler_data);
+ if (pre_unwind_handler)
+ spre_unwind_handler = make_catch_handler_closure (pre_unwind_handler,
+ pre_unwind_handler_data);
+ else
+ spre_unwind_handler = SCM_UNDEFINED;
+
+ return scm_catch_with_pre_unwind_handler (tag, sbody, shandler,
+ spre_unwind_handler);
+}
+
+SCM
+scm_internal_catch (SCM tag,
+ scm_t_catch_body 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_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data,
+ int lazy_catch_p)
+{
+ SCM sbody, shandler;
+
+ if (lazy_catch_p)
+ scm_c_issue_deprecation_warning
+ ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no longer.\n"
+ "supported. Instead the handler will be invoked from within the dynamic\n"
+ "context of the corresponding `throw'.\n"
+ "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
+ "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
+ "and adapt it (if necessary) to expect to be within the dynamic context\n"
+ "of the throw.");
+
+ sbody = make_catch_body_closure (body, body_data);
+ shandler = make_catch_handler_closure (handler, handler_data);
+
+ return scm_with_throw_handler (tag, sbody, shandler);
+}
+
+\f
+/* 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);
+}
+
+/* Derive the an exit status from the arguments to (quit ...). */
+int
+scm_exit_status (SCM args)
+{
+ if (!SCM_NULL_OR_NIL_P (args))
+ {
+ SCM cqa = SCM_CAR (args);
+
+ if (scm_is_integer (cqa))
+ return (scm_to_int (cqa));
+ else if (scm_is_false (cqa))
+ return 1;
+ }
+ return 0;
+}
+
+
+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)
+{
+ return scm_throw (key, args);
+}
+
+/* Unfortunately we have to support catch and throw before boot-9 has, um,
+ booted. So here are lame versions, which will get replaced with their scheme
+ equivalents. */
+
+SCM_SYMBOL (sym_pre_init_catch_tag, "%pre-init-catch-tag");
+
+static SCM
+pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
+{
+ SCM vm, prompt, res;
+
+ /* Only handle catch-alls without pre-unwind handlers */
+ if (!SCM_UNBNDP (pre_unwind_handler))
+ abort ();
+ if (scm_is_false (scm_eqv_p (tag, SCM_BOOL_T)))
+ abort ();
+
+ vm = scm_the_vm ();
+ prompt = scm_c_make_prompt (sym_pre_init_catch_tag,
+ SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp,
+ SCM_VM_DATA (vm)->ip, 1, -1, scm_i_dynwinds ());
+ scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
+
+ if (SCM_PROMPT_SETJMP (prompt))
+ {
+ /* nonlocal exit */
+ SCM args = scm_i_prompt_pop_abort_args_x (vm);
+ /* cdr past the continuation */
+ return scm_apply_0 (handler, scm_cdr (args));
+ }
+
+ res = scm_call_0 (thunk);
+ scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+
+ return res;
+}
+
+static int
+find_pre_init_catch (void)
+{
+ SCM winds;
+
+ /* Search the wind list for an appropriate prompt.
+ "Waiter, please bring us the wind list." */
+ for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
+ if (SCM_PROMPT_P (SCM_CAR (winds))
+ && scm_is_eq (SCM_PROMPT_TAG (SCM_CAR (winds)), sym_pre_init_catch_tag))
+ return 1;
+
+ return 0;
+}
+
+static SCM
+pre_init_throw (SCM k, SCM args)
+{
+ if (find_pre_init_catch ())
+ return scm_at_abort (sym_pre_init_catch_tag, scm_cons (k, args));
+ else
+ {
+ static int error_printing_error = 0;
+ static int error_printing_fallback = 0;
+
+ if (error_printing_fallback)
+ fprintf (stderr, "\nFailed to print exception.\n");
+ else if (error_printing_error)
+ {
+ fprintf (stderr, "\nError while printing exception:\n");
+ error_printing_fallback = 1;
+ fprintf (stderr, "Key: ");
+ scm_write (k, scm_current_error_port ());
+ fprintf (stderr, ", args: ");
+ scm_write (args, scm_current_error_port ());
+ scm_newline (scm_current_error_port ());
+ }
+ else
+ {
+ fprintf (stderr, "Throw without catch before boot:\n");
+ error_printing_error = 1;
+ scm_handle_by_message_noexit (NULL, k, args);
+ }
+
+ fprintf (stderr, "Aborting.\n");
+ abort ();
+ return SCM_BOOL_F; /* not reached */
+ }
+}
+
+void
+scm_init_throw ()
+{
+ tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
+ scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
+
+ catch_var = scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0,
+ pre_init_catch));
+ throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
+ pre_init_throw));
+
+#include "libguile/throw.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff