-/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 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
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program 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 General Public License for more details.
- *
- * 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, 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.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * 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 exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * 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. */
+ * 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
+ */
-/* 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 "libguile/_scm.h"
+#include "libguile/async.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 "libguile/debug.h"
-#endif
#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"
+#include "libguile/init.h"
\f
/* the jump buffer data structure */
-static scm_bits_t tc16_jmpbuffer;
+static scm_t_bits tc16_jmpbuffer;
#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
(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), (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
+#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)))
+#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
+#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
static int
-jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate)
+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_uintprint((scm_t_bits) JBJMPBUF (exp), 16, port);
scm_putc ('>', port);
return 1 ;
}
make_jmpbuf (void)
{
SCM answer;
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
{
-#ifdef DEBUG_EXTENSIONS
SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
-#else
- SCM_NEWSMOB (answer, tc16_jmpbuffer, 0);
-#endif
SETJBJMPBUF(answer, (jmp_buf *)0);
DEACTIVATEJB(answer);
}
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return answer;
}
\f
-/* scm_internal_catch (the guts of catch) */
+/* scm_c_catch (the guts of catch) */
struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
{
SCM retval;
};
+/* These are the structures we use to store pre-unwind handling (aka
+ "lazy") information for a regular catch, and put on the wind list
+ for a "lazy" catch. They store the pre-unwind 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.
-/* 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.
+ (We don't need anything like this to run the normal (post-unwind)
+ catch handler, because the same C frame runs both the body and the
+ handler.) */
+
+struct pre_unwind_data {
+ scm_t_catch_handler handler;
+ void *handler_data;
+ int running;
+ int lazy_catch_p;
+};
+
+
+/* scm_c_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
will be found. */
SCM
-scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data)
+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)
{
struct jmp_buf_and_retval jbr;
SCM jmpbuf;
SCM answer;
+ struct pre_unwind_data pre_unwind;
jmpbuf = make_jmpbuf ();
answer = SCM_EOL;
- scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
+ scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
SETJBJMPBUF(jmpbuf, &jbr.buf);
-#ifdef DEBUG_EXTENSIONS
- SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
-#endif
+ SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ());
+
+ pre_unwind.handler = pre_unwind_handler;
+ pre_unwind.handler_data = pre_unwind_handler_data;
+ pre_unwind.running = 0;
+ pre_unwind.lazy_catch_p = 0;
+ SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind);
+
if (setjmp (jbr.buf))
{
SCM throw_tag;
#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
DEACTIVATEJB (jmpbuf);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
throw_args = jbr.retval;
throw_tag = jbr.throw_tag;
jbr.throw_tag = SCM_EOL;
{
ACTIVATEJB (jmpbuf);
answer = body (body_data);
- SCM_REDEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
DEACTIVATEJB (jmpbuf);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
}
return answer;
}
+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);
+}
-\f
-/* scm_internal_lazy_catch (the guts of lazy catching) */
-
-/* The smob tag for lazy_catch smobs. */
-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
- 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_catch_handler_t handler;
- void *handler_data;
-};
+\f
+/* The smob tag for pre_unwind_data smobs. */
+static scm_t_bits tc16_pre_unwind_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)
+pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (closure);
+ struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_CELL_WORD_1 (closure);
char buf[200];
- sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>",
+ sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
(long) c->handler, (long) c->handler_data);
scm_puts (buf, port);
}
-/* Given a pointer to a lazy catch structure, return a smob for it,
+/* Given a pointer to a pre_unwind_data 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)
+make_pre_unwind_data (struct pre_unwind_data *c)
{
- SCM_RETURN_NEWSMOB (tc16_lazy_catch, c);
+ SCM_RETURN_NEWSMOB (tc16_pre_unwind_data, c);
}
-#define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
+#define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, 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. */
SCM
-scm_internal_lazy_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data)
+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 lazy_catch, answer;
- struct lazy_catch c;
+ SCM pre_unwind, answer;
+ struct pre_unwind_data c;
c.handler = handler;
c.handler_data = handler_data;
- lazy_catch = make_lazy_catch (&c);
+ c.running = 0;
+ c.lazy_catch_p = lazy_catch_p;
+ pre_unwind = make_pre_unwind_data (&c);
- SCM_REDEFER_INTS;
- scm_dynwinds = scm_acons (tag, lazy_catch, scm_dynwinds);
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_START;
+ scm_i_set_dynwinds (scm_acons (tag, pre_unwind, scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
answer = (*body) (body_data);
- SCM_REDEFER_INTS;
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
+ SCM_CRITICAL_SECTION_START;
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
return answer;
}
+/* 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)
+{
+ return scm_c_with_throw_handler (tag, body, body_data, handler, handler_data, 1);
+}
+
\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_the_last_stack_fluid_var on error. */
static SCM
-ss_handler (void *data, SCM tag, SCM throw_args)
+ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
{
/* Save the stack */
- scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid),
+ 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_catch_body_t body;
+ scm_t_catch_body body;
void *data;
};
SCM
scm_internal_stack_catch (SCM tag,
- scm_catch_body_t body,
+ scm_t_catch_body body,
void *body_data,
- scm_catch_handler_t handler,
+ scm_t_catch_handler handler,
void *handler_data)
{
struct cwss_data d;
{
struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
- return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
+ return scm_call_0 (c->body_proc);
}
{
SCM *handler_proc_p = (SCM *) handler_data;
- return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL);
+ return scm_apply_1 (*handler_proc_p, tag, throw_args);
}
/* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
hbpca_body (void *body_data)
{
struct hbpca_data *data = (struct hbpca_data *)body_data;
- return scm_apply (data->proc, data->args, SCM_EOL);
+ return scm_apply_0 (data->proc, data->args);
}
SCM
int
scm_exit_status (SCM args)
{
- if (SCM_NNULLP (args))
+ if (!SCM_NULL_OR_NIL_P (args))
{
SCM cqa = SCM_CAR (args);
- if (SCM_INUMP (cqa))
- return (SCM_INUM (cqa));
- else if (SCM_FALSEP (cqa))
+ if (scm_is_integer (cqa))
+ return (scm_to_int (cqa));
+ else if (scm_is_false (cqa))
return 1;
}
return 0;
handler_message (void *handler_data, SCM tag, SCM args)
{
char *prog_name = (char *) handler_data;
- SCM p = scm_cur_errp;
+ SCM p = scm_current_error_port ();
- if (scm_ilength (args) >= 3)
+ if (scm_ilength (args) == 4)
{
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);
+ SCM rest = SCM_CADDDR (args);
- if (SCM_BACKTRACE_P && SCM_NFALSEP (stack))
+ if (SCM_BACKTRACE_P && scm_is_true (stack))
{
+ SCM highlights;
+
+ if (scm_is_eq (tag, scm_arg_type_key)
+ || scm_is_eq (tag, scm_out_of_range_key))
+ highlights = rest;
+ else
+ highlights = SCM_EOL;
+
scm_puts ("Backtrace:\n", p);
- scm_display_backtrace (stack, p, SCM_UNDEFINED, SCM_UNDEFINED);
+ scm_display_backtrace_with_highlights (stack, p,
+ SCM_BOOL_F, SCM_BOOL_F,
+ highlights);
scm_newline (p);
}
scm_i_display_error (stack, p, subr, message, parts, rest);
SCM
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));
- }
+ 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);
+ scm_i_pthread_exit (NULL);
}
SCM
scm_handle_by_message_noexit (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);
return SCM_BOOL_F;
SCM
-scm_handle_by_throw (void *handler_data, SCM tag, SCM args)
+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 */
+/* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
-SCM_DEFINE (scm_catch, "catch", 3, 0, 0,
- (SCM key, SCM thunk, SCM handler),
+SCM_DEFINE (scm_catch_with_pre_unwind_handler, "catch", 3, 1, 0,
+ (SCM key, SCM thunk, SCM handler, SCM pre_unwind_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"
"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
+ "match this call to @code{catch}.\n"
+ "\n"
+ "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
+ "an exception that matches @var{key}, Guile calls the\n"
+ "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
+ "invoking the main @var{handler}. @var{pre-unwind-handler} should\n"
+ "be a procedure with the same signature as @var{handler}, that\n"
+ "is @code{(lambda (key . args))}. It is typically used to save\n"
+ "the stack at the point where the exception occurred, but can also\n"
+ "query other parts of the dynamic state at that point, such as\n"
+ "fluid values.\n"
+ "\n"
+ "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
+ "If it exits normally, Guile unwinds the stack and dynamic context\n"
+ "and then calls the normal (third argument) handler. If it exits\n"
+ "non-locally, that exit determines the continuation.")
+#define FUNC_NAME s_scm_catch_with_pre_unwind_handler
{
struct scm_body_thunk_data c;
- SCM_ASSERT (SCM_SYMBOLP (key) || SCM_EQ_P (key, SCM_BOOL_T),
+ 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);
+ /* scm_c_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_c_catch (key,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler,
+ SCM_UNBNDP (pre_unwind_handler) ? NULL : scm_handle_by_proc,
+ &pre_unwind_handler);
}
#undef FUNC_NAME
+/* The following function exists to provide backwards compatibility
+ for the C scm_catch API. Otherwise we could just change
+ "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
+SCM
+scm_catch (SCM key, SCM thunk, SCM handler)
+{
+ return scm_catch_with_pre_unwind_handler (key, thunk, handler, SCM_UNDEFINED);
+}
+
+
+SCM_DEFINE (scm_with_throw_handler, "with-throw-handler", 3, 0, 0,
+ (SCM key, SCM thunk, SCM handler),
+ "Add @var{handler} to the dynamic context as a throw handler\n"
+ "for key @var{key}, then invoke @var{thunk}.")
+#define FUNC_NAME s_scm_with_throw_handler
+{
+ 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_c_with_throw_handler takes care of the mechanics of setting
+ up a throw handler; we tell it to call scm_body_thunk to run the
+ body, and scm_handle_by_proc to deal with any throws to this
+ handler. 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_c_with_throw_handler (key,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler,
+ 0);
+}
+#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 (this is the major difference), and if\n"
- "handler returns, its value is returned from the throw.")
+ "not unwind the stack before invoking @var{handler}.\n"
+ "If the @var{handler} procedure returns normally, Guile\n"
+ "rethrows the same exception again to the next innermost catch,\n"
+ "lazy-catch or throw handler. If the @var{handler} exits\n"
+ "non-locally, that exit determines the continuation.")
#define FUNC_NAME s_scm_lazy_catch
{
struct scm_body_thunk_data c;
- SCM_ASSERT (SCM_SYMBOLP (key) || SCM_EQ_P (key, SCM_BOOL_T),
+ SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
key, SCM_ARG1, FUNC_NAME);
c.tag = key;
\f
/* throwing */
+static void toggle_pre_unwind_running (void *data)
+{
+ struct pre_unwind_data *pre_unwind = (struct pre_unwind_data *)data;
+ pre_unwind->running = !pre_unwind->running;
+}
+
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"
+ "@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);
- /* May return if handled by lazy catch. */
+ SCM_VALIDATE_SYMBOL (1, key);
return scm_ithrow (key, args, 1);
}
#undef FUNC_NAME
SCM
-scm_ithrow (SCM key, SCM args, int noreturn)
+scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
{
SCM jmpbuf = SCM_UNDEFINED;
SCM wind_goal;
SCM dynpair = SCM_UNDEFINED;
SCM winds;
+ if (scm_i_critical_section_level)
+ {
+ fprintf (stderr, "throw from within critical section.\n");
+ abort ();
+ }
+
+ rethrow:
+
/* 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))
+ for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
{
dynpair = SCM_CAR (winds);
- if (SCM_CONSP (dynpair))
+ if (scm_is_pair (dynpair))
{
SCM this_key = SCM_CAR (dynpair);
- if (SCM_EQ_P (this_key, SCM_BOOL_T) || SCM_EQ_P (this_key, key))
- break;
+ if (scm_is_eq (this_key, SCM_BOOL_T) || scm_is_eq (this_key, key))
+ {
+ jmpbuf = SCM_CDR (dynpair);
+
+ if (!SCM_PRE_UNWIND_DATA_P (jmpbuf))
+ break;
+ else
+ {
+ struct pre_unwind_data *c =
+ (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+ if (!c->running)
+ 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, 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))
+ if (scm_is_null (winds))
{
scm_handle_by_message (NULL, key, args);
abort ();
}
/* If the wind list is malformed, bail. */
- if (!SCM_CONSP (winds))
+ if (!scm_is_pair (winds))
abort ();
-
- jmpbuf = SCM_CDR (dynpair);
- for (wind_goal = scm_dynwinds;
- !SCM_EQ_P (SCM_CDAR (wind_goal), jmpbuf);
+ for (wind_goal = scm_i_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))
+ /* Is this a throw handler (or lazy catch)? In a wind list entry
+ for a throw handler or lazy catch, the key is bound to a
+ pre_unwind_data smob, not a jmpbuf. */
+ if (SCM_PRE_UNWIND_DATA_P (jmpbuf))
{
- struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (jmpbuf);
- SCM oldwinds = scm_dynwinds;
+ struct pre_unwind_data *c =
+ (struct pre_unwind_data *) 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;
+
+ /* For old-style lazy-catch behaviour, we unwind the dynamic
+ context before invoking the handler. */
+ if (c->lazy_catch_p)
+ {
+ scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
+ - scm_ilength (wind_goal)));
+ SCM_CRITICAL_SECTION_START;
+ handle = scm_i_dynwinds ();
+ scm_i_set_dynwinds (SCM_CDR (handle));
+ SCM_CRITICAL_SECTION_END;
+ }
+
+ /* Call the handler, with framing to set the pre-unwind
+ structure's running field while the handler is running, so we
+ can avoid recursing into the same handler again. Note that
+ if the handler returns normally, the running flag stays
+ set until some kind of non-local jump occurs. */
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (toggle_pre_unwind_running,
+ c,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (toggle_pre_unwind_running, c, 0);
answer = (c->handler) (c->handler_data, key, args);
- SCM_REDEFER_INTS;
- SCM_SETCDR (handle, scm_dynwinds);
- scm_dynwinds = handle;
- SCM_REALLOW_INTS;
- scm_dowinds (oldwinds, (scm_ilength (scm_dynwinds)
- - scm_ilength (oldwinds)));
- return answer;
+
+ /* There is deliberately no scm_dynwind_end call here. This
+ means that the unwind handler (toggle_pre_unwind_running)
+ stays in place until a non-local exit occurs, and will then
+ reset the pre-unwind structure's running flag. For sample
+ code where this makes a difference, see the "again but with
+ two chained throw handlers" test case in exceptions.test. */
+
+ /* If the handler returns, rethrow the same key and args. */
+ goto rethrow;
}
/* Otherwise, it's a normal catch. */
else if (SCM_JMPBUFP (jmpbuf))
{
+ struct pre_unwind_data * pre_unwind;
struct jmp_buf_and_retval * jbr;
- scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
+
+ /* Before unwinding anything, run the pre-unwind handler if
+ there is one, and if it isn't already running. */
+ pre_unwind = SCM_JBPREUNWIND (jmpbuf);
+ if (pre_unwind->handler && !pre_unwind->running)
+ {
+ /* Use framing to detect and avoid possible reentry into
+ this handler, which could otherwise cause an infinite
+ loop. */
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (toggle_pre_unwind_running,
+ pre_unwind,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (toggle_pre_unwind_running,
+ pre_unwind,
+ SCM_F_WIND_EXPLICITLY);
+ (pre_unwind->handler) (pre_unwind->handler_data, key, args);
+ scm_dynwind_end ();
+ }
+
+ /* Now unwind and jump. */
+ scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
- scm_ilength (wind_goal)));
jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
jbr->throw_tag = key;
jbr->retval = args;
+ scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf));
+ longjmp (*JBJMPBUF (jmpbuf), 1);
}
/* Otherwise, it's some random piece of junk. */
else
abort ();
-
-#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
-#endif
- longjmp (*JBJMPBUF (jmpbuf), 1);
}
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);
+ tc16_pre_unwind_data = scm_make_smob_type ("pre-unwind-data", 0);
+ scm_set_smob_print (tc16_pre_unwind_data, pre_unwind_data_print);
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/throw.x"
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff