-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
+ * If you do not wish that, delete this exception notice. */
+
+/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
+ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+
\f
#include <stdio.h>
-#include "_scm.h"
-#include "genio.h"
-#include "smob.h"
-#include "alist.h"
-#include "eval.h"
-#include "eq.h"
-#include "dynwind.h"
-#include "backtrace.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"
#ifdef DEBUG_EXTENSIONS
-#include "debug.h"
+#include "libguile/debug.h"
#endif
-#include "continuations.h"
-#include "stackchk.h"
+#include "libguile/continuations.h"
+#include "libguile/stackchk.h"
+#include "libguile/stacks.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
-#include "throw.h"
+#include "libguile/validate.h"
+#include "libguile/throw.h"
\f
-/* {Catch and Throw}
- */
-static int scm_tc16_jmpbuffer;
+/* the jump buffer data structure */
+static scm_bits_t tc16_jmpbuffer;
-#define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer)
-#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
-#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L)))
-#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L)))
+#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
-#ifndef DEBUG_EXTENSIONS
-#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
-#define SETJBJMPBUF SCM_SETCDR
-#else
-#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
-#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
-#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X))
-#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
-
-static scm_sizet freejb SCM_P ((SCM jbsmob));
+#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
+#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L)))
+#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L)))
-static scm_sizet
-freejb (jbsmob)
- SCM jbsmob;
-{
- scm_must_free ((char *) SCM_CDR (jbsmob));
- return sizeof (scm_cell);
-}
+#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
+#define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v)))
+#ifdef DEBUG_EXTENSIONS
+#define SCM_JBDFRAME(x) ((scm_debug_frame *) SCM_CELL_WORD_2 (x))
+#define SCM_SETJBDFRAME(x,v) (SCM_SET_CELL_WORD_2 ((x), (v)))
#endif
-static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
-printjb (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
+jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port);
- scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
- scm_intprint((SCM) JBJMPBUF(exp), 16, port);
- scm_gen_putc ('>', port);
+ 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_smobfuns jbsmob = {
- scm_mark0,
-#ifdef DEBUG_EXTENSIONS
- freejb,
-#else
- scm_free0,
-#endif
- printjb,
- 0
-};
-
-static SCM make_jmpbuf SCM_P ((void));
static SCM
-make_jmpbuf ()
+make_jmpbuf (void)
{
SCM answer;
- SCM_NEWCELL (answer);
SCM_REDEFER_INTS;
{
#ifdef DEBUG_EXTENSIONS
- char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
- SCM_SETCDR (answer, (SCM) mem);
+ SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
+#else
+ SCM_NEWSMOB (answer, tc16_jmpbuffer, 0);
#endif
- SCM_SETCAR (answer, scm_tc16_jmpbuffer);
SETJBJMPBUF(answer, (jmp_buf *)0);
DEACTIVATEJB(answer);
}
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 */
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, JMPBUF)
+ 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.
- JMPBUF is the Scheme jmpbuf object corresponding to this catch,
- which we have just created and initialized.
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, TAG, THROW_ARGS)
+ 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.
- 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.
+ 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.
+ 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
will be found. */
SCM
-scm_internal_catch (tag, body, body_data, handler, handler_data)
- SCM tag;
- scm_catch_body_t body;
- void *body_data;
- scm_catch_handler_t handler;
- void *handler_data;
+scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data)
{
struct jmp_buf_and_retval jbr;
SCM jmpbuf;
else
{
ACTIVATEJB (jmpbuf);
- answer = body (body_data, jmpbuf);
+ answer = body (body_data);
SCM_REDEFER_INTS;
DEACTIVATEJB (jmpbuf);
scm_dynwinds = SCM_CDR (scm_dynwinds);
}
-/* 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, or a
- function of one argument if the tag is #f.
-
- DATA contains the Scheme procedure to invoke. If the tag being
- caught is #f, then we pass JMPBUF to the body procedure; otherwise,
- it gets no arguments. */
-
-SCM
-scm_body_thunk (body_data, jmpbuf)
- void *body_data;
- SCM jmpbuf;
-{
- struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
-
- if (c->tag == SCM_BOOL_F)
- return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL);
- else
- return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
-}
-
-
-/* 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, or the procedure object
- should be otherwise protected from GC. */
-SCM
-scm_handle_by_proc (handler_data, tag, throw_args)
- void *handler_data;
- SCM tag;
- SCM throw_args;
-{
- SCM *handler_proc_p = (SCM *) handler_data;
-
- return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL);
-}
-
-
-SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
-SCM
-scm_catch (tag, thunk, handler)
- SCM tag;
- SCM thunk;
- SCM handler;
-{
- struct scm_body_thunk_data c;
-
- SCM_ASSERT ((tag == SCM_BOOL_F)
- || (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
- || (tag == SCM_BOOL_T),
- tag, SCM_ARG1, s_catch);
-
- c.tag = tag;
- c.body_proc = thunk;
-
- /* scm_internal_catch takes care of all the mechanics of setting up
- a catch tag; 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 (tag,
- scm_body_thunk, &c,
- scm_handle_by_proc, &handler);
-}
-
+\f
+/* scm_internal_lazy_catch (the guts of lazy catching) */
/* The smob tag for lazy_catch smobs. */
-static long tc16_lazy_catch;
+static scm_bits_t 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
appear in normal data structures, only in the wind list. However,
it might be nice for debugging someday... */
static int
-print_lazy_catch (SCM closure, SCM port, scm_print_state *pstate)
+lazy_catch_print (SCM closure, SCM port, scm_print_state *pstate)
{
- struct lazy_catch *c = (struct lazy_catch *) SCM_CDR (closure);
+ 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_gen_puts (scm_regular_string, buf, port);
+ scm_puts (buf, port);
return 1;
}
-static scm_smobfuns lazy_catch_funs = {
- scm_mark0, scm_free0, print_lazy_catch, 0
-};
-
/* 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, no?"). */
+ Gollombiere '72, non?"). */
static SCM
make_lazy_catch (struct lazy_catch *c)
{
- SCM smob;
-
- SCM_NEWCELL (smob);
- SCM_SETCDR (smob, c);
- SCM_SETCAR (smob, tc16_lazy_catch);
-
- return smob;
+ SCM_RETURN_NEWSMOB (tc16_lazy_catch, c);
}
-#define SCM_LAZY_CATCH_P(obj) \
- (SCM_NIMP (obj) && (SCM_CAR (obj) == tc16_lazy_catch))
+#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).
- - If handler returns, its value is returned from the throw.
- - BODY always receives #f as its JMPBUF argument (since there's no
- jmpbuf associated with a lazy catch, because we don't unwind the
- stack.) */
+ - If handler returns, its value is returned from the throw. */
SCM
-scm_internal_lazy_catch (tag, body, body_data, handler, handler_data)
- SCM tag;
- scm_catch_body_t body;
- void *body_data;
- scm_catch_handler_t handler;
- void *handler_data;
+scm_internal_lazy_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data)
{
SCM lazy_catch, answer;
struct lazy_catch c;
scm_dynwinds = scm_acons (tag, lazy_catch, scm_dynwinds);
SCM_REALLOW_INTS;
- answer = (*body) (body_data, SCM_BOOL_F);
+ answer = (*body) (body_data);
SCM_REDEFER_INTS;
scm_dynwinds = SCM_CDR (scm_dynwinds);
return answer;
}
+\f
+/* scm_internal_stack_catch
+ Use this one if you want debugging information to be stored in
+ scm_the_last_stack_fluid on error. */
-SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
-SCM
-scm_lazy_catch (tag, thunk, handler)
- SCM tag;
- SCM thunk;
- SCM handler;
+static SCM
+ss_handler (void *data, SCM tag, SCM throw_args)
{
- struct scm_body_thunk_data c;
+ /* Save the stack */
+ scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid),
+ scm_make_stack (SCM_BOOL_T, SCM_EOL));
+ /* Throw the error */
+ return scm_throw (tag, throw_args);
+}
- SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag))
- || (tag == SCM_BOOL_T),
- tag, SCM_ARG1, s_lazy_catch);
+struct cwss_data
+{
+ SCM tag;
+ scm_catch_body_t body;
+ void *data;
+};
- c.tag = tag;
- c.body_proc = thunk;
+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_internal_lazy_catch takes care of all the mechanics of
- setting up a lazy catch tag; 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 (tag,
- scm_body_thunk, &c,
- scm_handle_by_proc, &handler);
+SCM
+scm_internal_stack_catch (SCM tag,
+ scm_catch_body_t body,
+ void *body_data,
+ scm_catch_handler_t 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);
}
-/* The user has thrown to an uncaught key --- print a message and die.
- 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.
+\f
+/* body and handler functions for use with any of the above catch variants */
- 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. */
+/* 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_handle_by_message (handler_data, tag, args)
- void *handler_data;
- SCM tag;
- SCM args;
+scm_body_thunk (void *body_data)
{
- char *prog_name = (char *) handler_data;
- SCM p = scm_def_errp;
+ struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
- if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit")))))
- exit (scm_exit_status (args));
+ return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
+}
- if (! prog_name)
- prog_name = "guile";
- scm_gen_puts (scm_regular_string, prog_name, p);
- scm_gen_puts (scm_regular_string, ": ", p);
+/* 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 (scm_ilength (args) >= 3)
- {
- SCM message = SCM_CADR (args);
- SCM parts = SCM_CADDR (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;
- scm_display_error_message (message, parts, p);
- }
- else
- {
- scm_gen_puts (scm_regular_string, "uncaught throw to ", p);
- scm_prin1 (tag, p, 0);
- scm_gen_puts (scm_regular_string, ": ", p);
- scm_prin1 (args, p, 1);
- scm_gen_putc ('\n', p);
- }
+ return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL);
+}
- exit (2);
+/* 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 (data->proc, data->args, SCM_EOL);
+}
+
+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 (args)
- SCM args;
+scm_exit_status (SCM args)
{
if (SCM_NNULLP (args))
{
}
-SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
+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_NFALSEP (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_throw (key, args)
- SCM key;
- SCM args;
+scm_handle_by_message (void *handler_data, SCM tag, SCM args)
{
+ if (SCM_NFALSEP (scm_eq_p (tag, scm_str2symbol ("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 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 tag, 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 @var{key},\n"
+ "then @var{handler} is invoked this way:\n\n"
+ "@example\n"
+ "(handler key args ...)\n"
+ "@end example\n\n"
+ "@var{key} is a symbol or #t.\n\n"
+ "@var{thunk} takes no arguments. If @var{thunk} returns normally, that\n"
+ "is the return value of @code{catch}.\n\n"
+ "Handler is invoked outside the scope of its own @code{catch}. If\n"
+ "@var{handler} again throws to the same key, a new handler from further\n"
+ "up the call chain is invoked.\n\n"
+ "If the key is @code{#t}, then a throw to @emph{any} symbol will match\n"
+ "this call to @code{catch}.")
+#define FUNC_NAME s_scm_catch
+{
+ struct scm_body_thunk_data c;
+
+ SCM_ASSERT (SCM_SYMBOLP (tag) || SCM_EQ_P (tag, SCM_BOOL_T),
+ tag, SCM_ARG1, FUNC_NAME);
+
+ c.tag = tag;
+ c.body_proc = thunk;
+
+ /* scm_internal_catch takes care of all the mechanics of setting up
+ a catch tag; 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 (tag,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
+ (SCM tag, SCM thunk, SCM handler),
+ "")
+#define FUNC_NAME s_scm_lazy_catch
+{
+ struct scm_body_thunk_data c;
+
+ SCM_ASSERT (SCM_SYMBOLP (tag) || SCM_EQ_P (tag, SCM_BOOL_T),
+ tag, SCM_ARG1, FUNC_NAME);
+
+ c.tag = tag;
+ c.body_proc = thunk;
+
+ /* scm_internal_lazy_catch takes care of all the mechanics of
+ setting up a lazy catch tag; 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 (tag,
+ 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"
+ "#t.\n\n"
+ "If there is no handler at all, an error is signaled.")
+#define FUNC_NAME s_scm_throw
+{
+ SCM_VALIDATE_SYMBOL (1,key);
/* May return if handled by lazy catch. */
return scm_ithrow (key, args, 1);
}
-
+#undef FUNC_NAME
SCM
-scm_ithrow (key, args, noreturn)
- SCM key;
- SCM args;
- int noreturn;
+scm_ithrow (SCM key, SCM args, int noreturn)
{
- SCM jmpbuf;
+ SCM jmpbuf = SCM_UNDEFINED;
SCM wind_goal;
- if (SCM_NIMP (key) && SCM_JMPBUFP (key))
+ 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_CONSP (winds); winds = SCM_CDR (winds))
{
- jmpbuf = key;
- if (noreturn)
+ dynpair = SCM_CAR (winds);
+ if (SCM_CONSP (dynpair))
{
- SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf,
- "throw to dynamically inactive catch",
- s_throw);
- }
- else if (!JBACTIVE (jmpbuf))
- return SCM_UNSPECIFIED;
- }
- else
- {
- SCM dynpair = SCM_UNDEFINED;
- SCM winds;
+ SCM this_key = SCM_CAR (dynpair);
- if (noreturn)
- {
- SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1,
- s_throw);
+ if (SCM_EQ_P (this_key, SCM_BOOL_T) || SCM_EQ_P (this_key, key))
+ break;
}
- else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key)))
- return SCM_UNSPECIFIED;
-
- /* Search the wind list for an appropriate catch.
- "Waiter, please bring us the wind list." */
- for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds))
- {
- if (! SCM_CONSP (winds))
- abort ();
-
- dynpair = SCM_CAR (winds);
- if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair))
- {
- SCM this_key = SCM_CAR (dynpair);
+ }
- if (this_key == SCM_BOOL_T || this_key == key)
- break;
- }
- }
+#ifdef __GNUC__
+ /* Dirk:FIXME:: This bugfix should be removed some time. */
+ /* GCC 2.95.2 has a bug in its optimizer that makes it generate
+ incorrect code sometimes. This barrier stops it from being too
+ clever. */
+ asm volatile ("" : "=g" (winds));
+#endif
- /* If we didn't find anything, abort. scm_boot_guile should
- have established a catch-all, but obviously things are
- thoroughly screwed up. */
- if (winds == SCM_EOL)
- abort ();
+ /* 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_NULLP (winds))
+ {
+ scm_handle_by_message (NULL, key, args);
+ abort ();
+ }
- /* If the wind list is malformed, bail. */
- if (SCM_IMP (winds) || SCM_NCONSP (winds))
- abort ();
+ /* If the wind list is malformed, bail. */
+ if (!SCM_CONSP (winds))
+ abort ();
- if (dynpair != SCM_BOOL_F)
- jmpbuf = SCM_CDR (dynpair);
- else
- {
- if (!noreturn)
- return SCM_UNSPECIFIED;
- else
- {
- scm_exitval = scm_cons (key, args);
- scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
-#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
-#endif
- longjmp (SCM_JMPBUF (scm_rootcont), 1);
- }
- }
- }
+ jmpbuf = SCM_CDR (dynpair);
+
for (wind_goal = scm_dynwinds;
- SCM_CDAR (wind_goal) != jmpbuf;
+ !SCM_EQ_P (SCM_CDAR (wind_goal), jmpbuf);
wind_goal = SCM_CDR (wind_goal))
;
is bound to a lazy_catch smob, not a jmpbuf. */
if (SCM_LAZY_CATCH_P (jmpbuf))
{
- struct lazy_catch *c = (struct lazy_catch *) SCM_CDR (jmpbuf);
+ struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (jmpbuf);
SCM oldwinds = scm_dynwinds;
SCM handle, answer;
scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
void
scm_init_throw ()
{
- scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
- tc16_lazy_catch = scm_newsmob (&lazy_catch_funs);
-#include "throw.x"
+ 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);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/throw.x"
+#endif
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/