[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-50-gadb
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-50-gadbdfd6 |
|
Date: |
Fri, 26 Feb 2010 12:22:50 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=adbdfd6d2418b1404af48d480c2273f501517d6e
The branch, master has been updated
via adbdfd6d2418b1404af48d480c2273f501517d6e (commit)
via 416f26c7534a018c59f1c8d888dc9153f42d86d1 (commit)
via e10cf6b9c7e54c79db4de74584f1b0b65847d4fc (commit)
via d296431516dbf14535fc6eaba551fede19c09772 (commit)
via b8af64db76bc602517be300128be0dfb67fac89f (commit)
from da7fa082e80b2c3989c90031ee5356e5b65bd00b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit adbdfd6d2418b1404af48d480c2273f501517d6e
Author: Andy Wingo <address@hidden>
Date: Fri Feb 26 13:05:25 2010 +0100
rewinding prompts works
* libguile/control.h (SCM_PROMPT_HANDLER): Remove, it was unused.
(SCM_PROMPT_DYNWINDS): Rename from SCM_PROMPT_DYNENV.
* libguile/control.c: (scm_c_make_prompt): Take another arg, the winds
that are to be in place for the prompt. Fix allocation to be 4 words
instead of 5 (the handler was never used).
* libguile/eval.c (eval):
* libguile/throw.c (pre_init_catch): Adapt to scm_c_make_prompt change.
* libguile/vm-i-system.c (partial-cont-call): Grovel the new elements of
the wind list in order to call setjmp() on the new prompts. Pass
cookie to vm_reinstate_partial_continuation.
(prompt): Adapt to scm_c_make_prompt change.
* libguile/vm.c (vm_reinstate_partial_continuation): Take a cookie arg,
used when winding captured prompts onto the stack. Winding a prompt
implies making a new prompt, actually -- with new registers, a new
jump buffer, new winds, etc.
* test-suite/tests/control.test ("rewinding prompts"): Add a test for
rewinding prompts.
commit 416f26c7534a018c59f1c8d888dc9153f42d86d1
Author: Andy Wingo <address@hidden>
Date: Sun Jan 31 13:02:39 2010 +0100
catch, throw, with-throw-handler implemented in Scheme
* libguile/throw.c (tc16_jmpbuffer, tc16_pre_unwind_data): Remove these
smob types, and associated constructors and accessors (all internal).
(scm_catch, scm_catch_with_pre_unwind_handler):
(scm_with_throw_handler, scm_throw): Simply dispatch to scheme.
Lovely.
(tc16_catch_closure): Introduce a new applicable smob type, for use by
the C catch interface. All constructors and accessors are internal.
(scm_c_catch, scm_internal_catch, scm_c_with_throw_handler): Build
applicable smobs out of the C procedure arguments, so we can then
dispatch through scm_catch et al.
(scm_ithrow): Dispatch to scm_throw.
(pre_init_catch, pre_init_throw): Restricted catch/throw
implementation for use before boot-9 runs.
(scm_init_throw): Bind the pre-init catch and throw definitions.
* module/ice-9/boot-9.scm (prompt, abort): Move these definitions up in
the file.
(catch, throw, with-throw-handler): Implement in Scheme. Whee!
commit e10cf6b9c7e54c79db4de74584f1b0b65847d4fc
Author: Andy Wingo <address@hidden>
Date: Sun Jan 31 12:35:19 2010 +0100
deprecate lazy-catch
* libguile/deprecated.h:
* libguile/deprecated.c (scm_internal_lazy_catch, scm_lazy_catch):
Deprecate, and print out a nasty warning that people should change to
with-throw-handler.
* libguile/throw.h:
* libguile/throw.c (scm_c_with_throw_handler): Deprecate the use of the
lazy_catch_p argument, printing out a nasty warning if someone
actually passes 1 as that argument. The combination of the pre-unwind
and post-unwind handlers should be sufficient.
* test-suite/tests/exceptions.test: Remove lazy-catch tests, as they are
deprecated. Two of them fail:
* throw/catch: effect of lazy-catch unwinding on throw to another key
* throw/catch: repeat of previous test but with lazy-catch
Hopefully people are not depending on this behavior, and the warning is
sufficiently nasty for people to switch. We will see.
* test-suite/tests/eval.test ("promises"): Use with-throw-handler
instead of lazy-catch.
* doc/ref/api-debug.texi:
* doc/ref/api-control.texi: Update to remove references to lazy-catch,
folding in the useful bits to with-throw-handler.
commit d296431516dbf14535fc6eaba551fede19c09772
Author: Andy Wingo <address@hidden>
Date: Thu Feb 25 17:33:12 2010 +0100
fix a prompt bug
* libguile/control.h:
* libguile/control.c (scm_c_make_prompt): Instead of taking a VM arg,
take the registers directly.
(scm_c_abort): Declare as returning void. In fact it will never
return.
* libguile/eval.c (eval):
* libguile/throw.c (pre_init_catch): Adapt to prompt API change.
* libguile/vm-i-system.c (prompt): Pass the abort ip as the ip to
scm_c_make_prompt. This fixes a bug in which we used the "offset"
local var, but it wasn't guaranteed to be around after a longjmp.
commit b8af64db76bc602517be300128be0dfb67fac89f
Author: Andy Wingo <address@hidden>
Date: Thu Feb 25 13:17:34 2010 +0100
simplify handling of nonlocal prompt returns from c
* libguile/control.h:
* libguile/control.c (scm_i_prompt_pop_abort_args_x): New helper.
* libguile/eval.c (eval): Use the new helper.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-control.texi | 198 +++--------
doc/ref/api-debug.texi | 15 +-
libguile/control.c | 40 ++-
libguile/control.h | 16 +-
libguile/deprecated.c | 50 +++
libguile/deprecated.h | 10 +
libguile/eval.c | 22 +-
libguile/throw.c | 687 +++++++++-----------------------------
libguile/throw.h | 7 -
libguile/vm-i-system.c | 34 ++-
libguile/vm.c | 26 ++-
module/ice-9/boot-9.scm | 157 +++++++++-
test-suite/tests/control.test | 11 +
test-suite/tests/eval.test | 30 +-
test-suite/tests/exceptions.test | 153 ++--------
15 files changed, 564 insertions(+), 892 deletions(-)
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index c76bdfe..0e84d89 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -606,8 +606,7 @@ more conveniently.
@menu
* Exception Terminology:: Different ways to say the same thing.
* Catch:: Setting up to catch exceptions.
-* Throw Handlers:: Adding extra handling to a throw.
-* Lazy Catch:: Catch without unwinding the stack.
+* Throw Handlers:: Handling exceptions before unwinding the stack.
* Throw:: Throwing an exception.
* Exception Implementation:: How Guile implements exceptions.
@end menu
@@ -800,17 +799,53 @@ Operations}).
@subsubsection Throw Handlers
It's sometimes useful to be able to intercept an exception that is being
-thrown, but without changing where in the dynamic context that exception
-will eventually be caught. This could be to clean up some related state
-or to pass information about the exception to a debugger, for example.
-The @code{with-throw-handler} procedure provides a way to do this.
+thrown before the stack is unwound. This could be to clean up some
+related state, to print a backtrace, or to pass information about the
+exception to a debugger, for example. The @code{with-throw-handler}
+procedure provides a way to do this.
@deffn {Scheme Procedure} with-throw-handler key thunk handler
@deffnx {C Function} scm_with_throw_handler (key, thunk, handler)
Add @var{handler} to the dynamic context as a throw handler
for key @var{key}, then invoke @var{thunk}.
+
+This behaves exactly like @code{catch}, except that it does not unwind
+the stack before invoking @var{handler}. If the @var{handler} procedure
+returns normally, Guile rethrows the same exception again to the next
+innermost catch or throw handler. @var{handler} may exit nonlocally, of
+course, via an explicit throw or via invoking a continuation.
@end deffn
+Typically @var{handler} is used to display a backtrace of the stack at
+the point where the corresponding @code{throw} occurred, or to save off
+this information for possible display later.
+
+Not unwinding the stack means that throwing an exception that is handled
+via a throw handler is equivalent to calling the throw handler handler
+inline instead of each @code{throw}, and then omitting the surrounding
address@hidden In other words,
+
address@hidden
+(with-throw-handler 'key
+ (lambda () @dots{} (throw 'key args @dots{}) @dots{})
+ handler)
address@hidden lisp
+
address@hidden
+is mostly equivalent to
+
address@hidden
+((lambda () @dots{} (handler 'key args @dots{}) @dots{}))
address@hidden lisp
+
+In particular, the dynamic context when @var{handler} is invoked is that
+of the site where @code{throw} is called. The examples are not quite
+equivalent, because the body of a @code{with-throw-handler} is not in
+tail position with respect to the @code{with-throw-handler}, and if
address@hidden exits normally, Guile arranges to rethrow the error, but
+hopefully the intention is clear. (For an introduction to what is meant
+by dynamic context, @xref{Dynamic Wind}.)
+
@deftypefn {C Function} 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)
The above @code{scm_with_throw_handler} takes Scheme procedures as body
(thunk) and handler arguments. @code{scm_c_with_throw_handler} is an
@@ -838,141 +873,13 @@ everything that a @code{catch} would do until the point
where
then it rethrows to the next innermost @code{catch} or throw handler
instead.
+Note also that since the dynamic context is not unwound, if a
address@hidden handler throws to a key that does not match
+the @code{with-throw-handler} expression's @var{key}, the new throw may
+be handled by a @code{catch} or throw handler that is @emph{closer} to
+the throw than the first @code{with-throw-handler}.
address@hidden Lazy Catch
address@hidden Catch Without Unwinding
-
-Before version 1.8, Guile's closest equivalent to
address@hidden was @code{lazy-catch}. From version 1.8
-onwards we recommend using @code{with-throw-handler} because its
-behaviour is more useful than that of @code{lazy-catch}, but
address@hidden is still supported as well.
-
-A @dfn{lazy catch} is used in the same way as a normal @code{catch},
-with @var{key}, @var{thunk} and @var{handler} arguments specifying the
-exception type, normal case code and handler procedure, but differs in
-one important respect: the handler procedure is executed without
-unwinding the call stack from the context of the @code{throw} expression
-that caused the handler to be invoked.
-
address@hidden {Scheme Procedure} lazy-catch key thunk handler
address@hidden {C Function} scm_lazy_catch (key, thunk, handler)
-This behaves exactly like @code{catch}, except that it does
-not unwind the stack before invoking @var{handler}.
-If the @var{handler} procedure returns normally, Guile
-rethrows the same exception again to the next innermost catch,
-lazy-catch or throw handler. If the @var{handler} exits
-non-locally, that exit determines the continuation.
address@hidden deffn
-
address@hidden {C Function} SCM scm_internal_lazy_catch (SCM tag,
scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void
*handler_data)
-The above @code{scm_lazy_catch} takes Scheme procedures as body and
-handler arguments. @code{scm_internal_lazy_catch} is an equivalent
-taking C functions. See @code{scm_internal_catch} (@pxref{Catch}) for
-a description of the parameters, the behaviour however of course
-follows @code{lazy-catch}.
address@hidden deftypefn
-
-Typically @var{handler} is used to display a backtrace of the stack at
-the point where the corresponding @code{throw} occurred, or to save off
-this information for possible display later.
-
-Not unwinding the stack means that throwing an exception that is caught
-by a @code{lazy-catch} is @emph{almost} equivalent to calling the
address@hidden's handler inline instead of each @code{throw}, and
-then omitting the surrounding @code{lazy-catch}. In other words,
-
address@hidden
-(lazy-catch 'key
- (lambda () @dots{} (throw 'key args @dots{}) @dots{})
- handler)
address@hidden lisp
-
address@hidden
-is @emph{almost} equivalent to
-
address@hidden
-((lambda () @dots{} (handler 'key args @dots{}) @dots{}))
address@hidden lisp
-
address@hidden
-But why only @emph{almost}? The difference is that with
address@hidden (as with normal @code{catch}), the dynamic context is
-unwound back to just outside the @code{lazy-catch} expression before
-invoking the handler. (For an introduction to what is meant by dynamic
-context, @xref{Dynamic Wind}.)
-
-Then, when the handler @emph{itself} throws an exception, that exception
-must be caught by some kind of @code{catch} (including perhaps another
address@hidden) higher up the call stack.
-
-The dynamic context also includes @code{with-fluids} blocks
-(@pxref{Fluids and Dynamic States}),
-so the effect of unwinding the dynamic context can also be seen in fluid
-variable values. This is illustrated by the following code, in which
-the normal case thunk uses @code{with-fluids} to temporarily change the
-value of a fluid:
-
address@hidden
-(define f (make-fluid))
-(fluid-set! f "top level value")
-
-(define (handler . args)
- (cons (fluid-ref f) args))
-
-(lazy-catch 'foo
- (lambda ()
- (with-fluids ((f "local value"))
- (throw 'foo)))
- handler)
address@hidden
-("top level value" foo)
-
-((lambda ()
- (with-fluids ((f "local value"))
- (handler 'foo))))
address@hidden
-("local value" foo)
address@hidden lisp
-
address@hidden
-In the @code{lazy-catch} version, the unwinding of dynamic context
-restores @code{f} to its value outside the @code{with-fluids} block
-before the handler is invoked, so the handler's @code{(fluid-ref f)}
-returns the external value.
-
address@hidden is useful because it permits the implementation of
-debuggers and other reflective programming tools that need to access the
-state of the call stack at the exact point where an exception or an
-error is thrown. For an example of this, see REFFIXME:stack-catch.
-
-It should be obvious from the above that @code{lazy-catch} is very
-similar to @code{with-throw-handler}. In fact Guile implements
address@hidden in exactly the same way as @code{with-throw-handler},
-except with a flag set to say ``where there are slight differences
-between what @code{with-throw-handler} and @code{lazy-catch} would do,
-do what @code{lazy-catch} has always done''. There are two such
-differences:
-
address@hidden
address@hidden
address@hidden handlers execute in the full dynamic context
-of the originating @code{throw} call. @code{lazy-catch} handlers
-execute in the dynamic context of the @code{lazy-catch} expression,
-excepting only that the stack has not yet been unwound from the point of
-the @code{throw} call.
-
address@hidden
-If a @code{with-throw-handler} handler throws to a key that does not
-match the @code{with-throw-handler} expression's @var{key}, the new
-throw may be handled by a @code{catch} or throw handler that is _closer_
-to the throw than the first @code{with-throw-handler}. If a
address@hidden handler throws, it will always be handled by a
address@hidden or throw handler that is higher up the dynamic context than
-the first @code{lazy-catch}.
address@hidden enumerate
-
-Here is an example to illustrate the second difference:
+Here is an example to illustrate this behavior:
@lisp
(catch 'a
@@ -990,14 +897,7 @@ Here is an example to illustrate the second difference:
@noindent
This code will call @code{inner-handler} and then continue with the
-continuation of the inner @code{catch}. If the
address@hidden was changed to @code{lazy-catch}, however, the
-code would call @code{outer-handler} and then continue with the
-continuation of the outer @code{catch}.
-
-Modulo these two differences, any statements in the previous and
-following subsections about throw handlers apply to lazy catches as
-well.
+continuation of the inner @code{catch}.
@node Throw
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index c29bfdf..3c9ec11 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -400,13 +400,12 @@ equivalent in C. In Scheme, this means you need
something like this:
@end lisp
@noindent
-The @code{catch} here can also be @code{lazy-catch} or
address@hidden; see @ref{Throw Handlers} and @ref{Lazy Catch}
-for the details of how these differ from @code{catch}. The @code{#t}
-means that the catch is applicable to all kinds of error; if you want to
-restrict your catch to just one kind of error, you can put the symbol
-for that kind of error instead of @code{#t}. The equivalent to this in
-C would be something like this:
+The @code{catch} here can also be @code{with-throw-handler}; see @ref{Throw
+Handlers} for information on the when you might want to use
address@hidden instead of @code{catch}. The @code{#t} means that the
+catch is applicable to all kinds of error; if you want to restrict your catch
to
+just one kind of error, you can put the symbol for that kind of error instead
of
address@hidden The equivalent to this in C would be something like this:
@lisp
SCM my_body_proc (void *body_data)
diff --git a/libguile/control.c b/libguile/control.c
index 9f23f30..6a060f4 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -32,31 +32,47 @@ SCM scm_sys_default_prompt_tag;
SCM
-scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p,
- scm_t_int64 vm_cookie)
+scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
+ scm_t_uint8 escape_only_p, scm_t_int64 vm_cookie,
+ SCM winds)
{
scm_t_bits tag;
- SCM ret;
struct scm_prompt_registers *regs;
tag = scm_tc7_prompt;
if (escape_only_p)
tag |= (SCM_F_PROMPT_ESCAPE<<8);
- ret = scm_words (tag, 5);
regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
- regs->fp = SCM_VM_DATA (vm)->fp;
- regs->sp = SCM_VM_DATA (vm)->sp;
- regs->ip = SCM_VM_DATA (vm)->ip;
+ regs->fp = fp;
+ regs->sp = sp;
+ regs->ip = abort_ip;
regs->cookie = vm_cookie;
- SCM_SET_CELL_OBJECT (ret, 1, k);
- SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
- SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ());
+ return scm_double_cell (tag, SCM_UNPACK (k), (scm_t_bits)regs,
+ SCM_UNPACK (winds));
+}
- return ret;
+/* Only to be called if the SCM_PROMPT_SETJMP returns 1 */
+SCM
+scm_i_prompt_pop_abort_args_x (SCM prompt)
+{
+ size_t i, n;
+ SCM vals = SCM_EOL;
+
+ n = scm_to_size_t (SCM_PROMPT_REGISTERS (prompt)->sp[0]);
+ for (i = 0; i < n; i++)
+ vals = scm_cons (SCM_PROMPT_REGISTERS (prompt)->sp[-(i + 1)], vals);
+
+ /* The abort did reset the VM's registers, but then these values
+ were pushed on; so we need to pop them ourselves. */
+ SCM_VM_DATA (scm_the_vm ())->sp -= n + 1;
+ /* FIXME NULLSTACK */
+
+ return vals;
}
+
#ifdef WORDS_BIGENDIAN
#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
#define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
@@ -170,7 +186,7 @@ reify_partial_continuation (SCM vm, SCM prompt, SCM
extwinds,
return ret;
}
-SCM
+void
scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
{
SCM cont, winds, prompt = SCM_BOOL_F;
diff --git a/libguile/control.h b/libguile/control.h
index 146e216..923a45e 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -27,8 +27,7 @@
#define SCM_PROMPT_ESCAPE_P(x) (SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_ESCAPE)
#define SCM_PROMPT_TAG(x) (SCM_CELL_OBJECT ((x), 1))
#define SCM_PROMPT_REGISTERS(x) ((struct
scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
-#define SCM_PROMPT_DYNENV(x) (SCM_CELL_OBJECT ((x), 3))
-#define SCM_PROMPT_HANDLER(x) (SCM_CELL_OBJECT ((x), 4))
+#define SCM_PROMPT_DYNWINDS(x) (SCM_CELL_OBJECT ((x), 3))
#define SCM_PROMPT_SETJMP(p) (SCM_I_SETJMP (SCM_PROMPT_REGISTERS (p)->regs))
@@ -45,10 +44,15 @@ struct scm_prompt_registers
SCM_INTERNAL SCM scm_sys_default_prompt_tag;
-SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p,
- scm_t_int64 cookie);
-SCM_INTERNAL SCM scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
- scm_t_int64 cookie) SCM_NORETURN;
+SCM_INTERNAL SCM scm_c_make_prompt (SCM k, SCM *fp, SCM *sp,
+ scm_t_uint8 *abort_ip,
+ scm_t_uint8 escape_only_p,
+ scm_t_int64 vm_cookie,
+ SCM winds);
+SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM prompt);
+
+SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
+ scm_t_int64 cookie) SCM_NORETURN;
SCM_INTERNAL SCM scm_at_abort (SCM tag, SCM args) SCM_NORETURN;
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 54f0055..95f6f46 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -1816,6 +1816,56 @@ scm_i_subr_p (SCM x)
}
+
+SCM
+scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_lazy_catch' is no longer supported. Instead this call
will\n"
+ "dispatch to `scm_c_with_throw_handler'. Your handler will be invoked
from\n"
+ "within the dynamic context of the corresponding `throw'.\n"
+ "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
+ "Please modify your program to use `scm_c_with_throw_handler' directly,\n"
+ "and adapt it (if necessary) to expect to be within the dynamic context\n"
+ "of the throw.");
+ return scm_c_with_throw_handler (tag, body, body_data, handler,
handler_data, 0);
+}
+
+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"
+ "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_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
+ key, SCM_ARG1, FUNC_NAME);
+
+ c.tag = key;
+ c.body_proc = thunk;
+
+ scm_c_issue_deprecation_warning
+ ("`lazy-catch' is no longer supported. Instead this call will dispatch\n"
+ "to `with-throw-handler'. Your handler will be invoked from within the\n"
+ "dynamic context of the corresponding `throw'.\n"
+ "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
+ "Please modify your program to use `with-throw-handler' directly, and\n"
+ "adapt it (if necessary) to expect to be within the dynamic context of\n"
+ "the throw.");
+
+ return scm_c_with_throw_handler (key,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler, 0);
+}
+#undef FUNC_NAME
+
+
+
void
scm_i_init_deprecated ()
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 9832cfb..7f26f3f 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -611,6 +611,16 @@ SCM_DEPRECATED int scm_i_subr_p (SCM x);
+/* Deprecated 2010-01-31, use with-throw-handler instead */
+SCM_DEPRECATED SCM scm_lazy_catch (SCM tag, SCM thunk, SCM handler);
+SCM_DEPRECATED SCM scm_internal_lazy_catch (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data);
+
+
+
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/eval.c b/libguile/eval.c
index c82e543..ba358a7 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -427,28 +427,20 @@ eval (SCM x, SCM env)
case SCM_M_PROMPT:
{
- SCM prompt, handler, res;
+ SCM vm, prompt, handler, res;
- prompt = scm_c_make_prompt (scm_the_vm (), eval (CAR (mx), env), 0,
-1);
+ vm = scm_the_vm ();
+ prompt = scm_c_make_prompt (eval (CAR (mx), env), SCM_VM_DATA (vm)->fp,
+ SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
+ 0, -1, scm_i_dynwinds ());
handler = eval (CDDR (mx), env);
scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
if (SCM_PROMPT_SETJMP (prompt))
{
- /* The prompt exited nonlocally. The args are on the VM stack. */
- size_t i, n;
- SCM vals = SCM_EOL;
- n = scm_to_size_t (SCM_PROMPT_REGISTERS (prompt)->sp[0]);
- for (i = 0; i < n; i++)
- vals = scm_cons (SCM_PROMPT_REGISTERS (prompt)->sp[-(i + 1)],
vals);
- /* The abort did reset the VM's registers, but then these values
- were pushed on; so we need to pop them ourselves. */
- SCM_VM_DATA (scm_the_vm ())->sp -= n + 1;
- /* FIXME NULLSTACK */
-
- /* FIXME mark cont as non-reentrant */
+ /* The prompt exited nonlocally. */
proc = handler;
- args = vals;
+ args = scm_i_prompt_pop_abort_args_x (prompt);
goto apply_proc;
}
diff --git a/libguile/throw.c b/libguile/throw.c
index fd08e6e..04bcba8 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009,
2010 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
@@ -25,102 +25,138 @@
#include <stdio.h>
#include <unistdio.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/control.h"
+#include "libguile/deprecation.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/vm.h"
#include "libguile/throw.h"
#include "libguile/init.h"
#include "libguile/strings.h"
-#include "libguile/vm.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. */
+
+
+#define CACHE_VAR(var,name) \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ { \
+ var = scm_module_variable (scm_the_root_module (), \
+ scm_from_locale_symbol (name)); \
+ if (scm_is_false (var)) \
+ abort (); \
+ }
+
-/* the jump buffer data structure */
-static scm_t_bits tc16_jmpbuffer;
-#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
+SCM
+scm_catch (SCM key, SCM thunk, SCM handler)
+{
+ CACHE_VAR (var, "catch");
-#define JBACTIVE(OBJ) (SCM_SMOB_FLAGS (OBJ) & 1L)
-#define ACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 1L))
-#define DEACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 0L))
+ return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
+}
-#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_SMOB_DATA_1 (OBJ))
-#define SETJBJMPBUF(x, v) (SCM_SET_SMOB_DATA_1 ((x), (scm_t_bits) (v)))
-#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_SMOB_DATA_3
(x))
-#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_SMOB_DATA_3 ((x), (scm_t_bits) (v)))
+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
+ {
+ CACHE_VAR (var, "catch");
+
+ return scm_call_4 (scm_variable_ref (var), key, thunk, handler,
+ pre_unwind_handler);
+ }
+}
-static int
-jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+SCM
+scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
{
- scm_puts ("#<jmpbuffer ", port);
- scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
- scm_uintprint((scm_t_bits) JBJMPBUF (exp), 16, port);
- scm_putc ('>', port);
- return 1 ;
+ CACHE_VAR (var, "with-throw-handler");
+
+ return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
}
-static SCM
-make_jmpbuf (void)
+SCM
+scm_throw (SCM key, SCM args)
{
- SCM answer;
- SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
- SETJBJMPBUF(answer, (scm_i_jmp_buf *)0);
- DEACTIVATEJB(answer);
- return answer;
+ CACHE_VAR (var, "throw");
+
+ return scm_apply_1 (scm_variable_ref (var), key, args);
}
-/* scm_c_catch (the guts of catch) */
-struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
-{
- scm_i_jmp_buf buf; /* must be first */
- SCM throw_tag;
- SCM retval;
-};
+/* Now some support for C bodies and catch handlers */
-/* 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.
-
- (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;
+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;
+}
-/* 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.
+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;
+}
- The function is designed to be usable from C code, but is general
- enough to implement all the semantics Guile Scheme expects from
- throw.
+static SCM
+apply_catch_closure (SCM clo, SCM args)
+{
+ void *data = (void*)SCM_SMOB_DATA_2 (clo);
- TAG is the catch tag. Typically, this is a symbol, but this
+ 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;
@@ -165,83 +201,18 @@ scm_c_catch (SCM tag,
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;
- SCM vm;
- SCM *sp = NULL, *fp = NULL; /* to reset the vm */
- struct pre_unwind_data pre_unwind;
-
- vm = scm_the_vm ();
- if (scm_is_true (vm))
- {
- sp = SCM_VM_DATA (vm)->sp;
- fp = SCM_VM_DATA (vm)->fp;
- }
-
- jmpbuf = make_jmpbuf ();
- answer = SCM_EOL;
- scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
- SETJBJMPBUF(jmpbuf, &jbr.buf);
-
- 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 (SCM_I_SETJMP (jbr.buf))
- {
- SCM throw_tag;
- SCM throw_args;
-
-#ifdef STACK_CHECKING
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
- SCM_CRITICAL_SECTION_START;
- DEACTIVATEJB (jmpbuf);
- 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;
- jbr.retval = SCM_EOL;
- if (scm_is_true (vm))
- {
- SCM_VM_DATA (vm)->sp = sp;
- SCM_VM_DATA (vm)->fp = fp;
-#ifdef VM_ENABLE_STACK_NULLING
- /* see vm.c -- you'll have to enable this manually */
- memset (sp + 1, 0,
- (SCM_VM_DATA (vm)->stack_size
- - (sp + 1 - SCM_VM_DATA (vm)->stack_base)) * sizeof(SCM));
-#endif
- }
- else if (scm_is_true ((vm = scm_the_vm ())))
- {
- /* oof, it's possible this catch was called before the vm was
- booted... yick. anyway, try to reset the vm stack. */
- SCM_VM_DATA (vm)->sp = SCM_VM_DATA (vm)->stack_base - 1;
- SCM_VM_DATA (vm)->fp = NULL;
-#ifdef VM_ENABLE_STACK_NULLING
- /* see vm.c -- you'll have to enable this manually */
- memset (SCM_VM_DATA (vm)->stack_base, 0,
- SCM_VM_DATA (vm)->stack_size * sizeof(SCM));
-#endif
- }
-
- answer = handler (handler_data, throw_tag, throw_args);
- }
+ 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
- {
- ACTIVATEJB (jmpbuf);
- answer = body (body_data);
- SCM_CRITICAL_SECTION_START;
- DEACTIVATEJB (jmpbuf);
- scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
- SCM_CRITICAL_SECTION_END;
- }
- return answer;
+ spre_unwind_handler = SCM_UNDEFINED;
+
+ return scm_catch_with_pre_unwind_handler (tag, sbody, shandler,
+ spre_unwind_handler);
}
SCM
@@ -249,46 +220,13 @@ 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);
-}
-
-
-
-/* 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
-pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate
SCM_UNUSED)
-{
- struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_SMOB_DATA_1
(closure);
- char buf[200];
-
- sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
- (long) c->handler, (long) c->handler_data);
- scm_puts (buf, port);
-
- return 1;
+ return scm_c_catch (tag,
+ body, body_data,
+ handler, handler_data,
+ NULL, NULL);
}
-/* 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_pre_unwind_data (struct pre_unwind_data *c)
-{
- SCM_RETURN_NEWSMOB (tc16_pre_unwind_data, c);
-}
-
-#define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data,
obj))
-
SCM
scm_c_with_throw_handler (SCM tag,
scm_t_catch_body body,
@@ -297,35 +235,22 @@ scm_c_with_throw_handler (SCM tag,
void *handler_data,
int lazy_catch_p)
{
- SCM pre_unwind, answer;
- struct pre_unwind_data c;
-
- c.handler = handler;
- c.handler_data = handler_data;
- c.running = 0;
- c.lazy_catch_p = lazy_catch_p;
- pre_unwind = make_pre_unwind_data (&c);
-
- 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_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);
+ 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);
}
@@ -354,7 +279,7 @@ 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);
+ return scm_c_with_throw_handler (d->tag, d->body, d->data, ss_handler, NULL,
0);
}
SCM
@@ -564,348 +489,60 @@ scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM
tag, SCM args)
return SCM_UNSPECIFIED; /* never returns */
}
-
-
-/* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
-
-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"
- "@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}.\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_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
- key, SCM_ARG1, FUNC_NAME);
-
- c.tag = key;
- c.body_proc = thunk;
-
- /* 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 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_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
-
-
-
-/* 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"
- "@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_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
{
- SCM_VALIDATE_SYMBOL (1, key);
- return scm_ithrow (key, args, 1);
+ return scm_throw (key, args);
}
-#undef FUNC_NAME
-SCM
-scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
+/* 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. */
+static SCM
+pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
- SCM jmpbuf = SCM_UNDEFINED;
- SCM wind_goal;
+ SCM vm, prompt, res;
- SCM dynpair = SCM_UNDEFINED;
- SCM winds;
-
- if (SCM_I_CURRENT_THREAD->critical_section_level)
- {
- SCM s = args;
- int i = 0;
-
- /*
- We have much better routines for displaying Scheme, but we're
- already inside a pernicious error, and it's unlikely that they
- are available to us. We try to print something useful anyway,
- so users don't need a debugger to find out what went wrong.
- */
- fprintf (stderr, "throw from within critical section.\n");
- if (scm_is_symbol (key))
- {
- if (scm_i_is_narrow_symbol (key))
- fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key));
- else
- ulc_fprintf (stderr, "error key: %llU\n", scm_i_symbol_wide_chars
(key));
- }
-
- for (; scm_is_pair (s); s = scm_cdr (s), i++)
- {
- char const *str = NULL;
- if (scm_is_string (scm_car (s)))
- str = scm_i_string_chars (scm_car (s));
- else if (scm_is_symbol (scm_car (s)))
- str = scm_i_symbol_chars (scm_car (s));
-
- if (str != NULL)
- fprintf (stderr, "argument %d: %s\n", i, str);
- }
- abort ();
- }
-
- rethrow:
-
- /* Search the wind list for an appropriate catch.
- "Waiter, please bring us the wind list." */
- for (winds = scm_i_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))
- {
- jmpbuf = SCM_CDR (dynpair);
-
- if (!SCM_PRE_UNWIND_DATA_P (jmpbuf))
- break;
- else
- {
- struct pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
- if (!c->running)
- 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))
+ /* 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 ();
-
- for (wind_goal = scm_i_dynwinds ();
- (!scm_is_pair (SCM_CAR (wind_goal))
- || !scm_is_eq (SCM_CDAR (wind_goal), jmpbuf));
- wind_goal = SCM_CDR (wind_goal))
- ;
-
- /* 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 pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
- SCM handle, answer;
-
- /* 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);
-
- /* 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;
- }
+ vm = scm_the_vm ();
+ prompt = scm_c_make_prompt (scm_fluid_ref (scm_sys_default_prompt_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)));
- /* Otherwise, it's a normal catch. */
- else if (SCM_JMPBUFP (jmpbuf))
+ if (SCM_PROMPT_SETJMP (prompt))
{
- struct pre_unwind_data * pre_unwind;
- struct jmp_buf_and_retval * jbr;
-
- /* 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_LONGJMP (*JBJMPBUF (jmpbuf), 1);
+ /* nonlocal exit */
+ SCM args = scm_i_prompt_pop_abort_args_x (prompt);
+ /* cdr past the continuation */
+ return scm_apply_0 (handler, scm_cdr (args));
}
- /* Otherwise, it's some random piece of junk. */
- else
- abort ();
+ res = scm_call_0 (thunk);
+ scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
-#ifdef __ia64__
- /* On IA64, we #define longjmp as setcontext, and GCC appears not to
- know that that doesn't return. */
- return SCM_UNSPECIFIED;
-#endif
+ return res;
}
+static SCM
+pre_init_throw (SCM args)
+{
+ return scm_at_abort (scm_fluid_ref (scm_sys_default_prompt_tag), args);
+}
void
scm_init_throw ()
{
- tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0);
- scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print);
+ tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
+ scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
- tc16_pre_unwind_data = scm_make_smob_type ("pre-unwind-data", 0);
- scm_set_smob_print (tc16_pre_unwind_data, pre_unwind_data_print);
+ scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, pre_init_catch));
+ scm_c_define ("throw", scm_c_make_gsubr ("throw", 0, 0, 1, pre_init_throw));
#include "libguile/throw.x"
}
diff --git a/libguile/throw.h b/libguile/throw.h
index 1ed6ba6..d14cbf8 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -52,12 +52,6 @@ SCM_API SCM scm_internal_catch (SCM tag,
scm_t_catch_handler handler,
void *handler_data);
-SCM_API SCM scm_internal_lazy_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data);
-
SCM_API SCM scm_internal_stack_catch (SCM tag,
scm_t_catch_body body,
void *body_data,
@@ -91,7 +85,6 @@ SCM_API int scm_exit_status (SCM args);
SCM_API SCM scm_catch_with_pre_unwind_handler (SCM tag, SCM thunk, SCM
handler, SCM lazy_handler);
SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
-SCM_API SCM scm_lazy_catch (SCM tag, SCM thunk, SCM handler);
SCM_API SCM scm_ithrow (SCM key, SCM args, int noreturn);
SCM_API SCM scm_throw (SCM key, SCM args);
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 56df727..e21a910 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -995,7 +995,7 @@ VM_DEFINE_INSTRUCTION (89, continuation_call,
"continuation-call", 0, -1, 0)
VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
{
- SCM vmcont, intwinds;
+ SCM vmcont, intwinds, prevwinds;
POP (intwinds);
POP (vmcont);
SYNC_REGISTER ();
@@ -1003,7 +1003,18 @@ VM_DEFINE_INSTRUCTION (94, partial_cont_call,
"partial-cont-call", 0, -1, 0)
{ finish_args = vmcont;
goto vm_error_continuation_not_rewindable;
}
- vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp);
+ prevwinds = scm_i_dynwinds ();
+ vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
+ vm_cookie);
+
+ /* Rewind prompt jmpbuffers, if any. */
+ {
+ SCM winds = scm_i_dynwinds ();
+ for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
+ if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car
(winds)))
+ break;
+ }
+
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
@@ -1479,19 +1490,22 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0)
POP (k);
SYNC_REGISTER ();
- /* Push the prompt onto the dynamic stack. The setjmp itself has to be local
- to this procedure. */
- /* FIXME: do more error checking */
- prompt = scm_c_make_prompt (vm, k, escape_only_p, vm_cookie);
- scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
+ /* Push the prompt onto the dynamic stack. */
+ prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
+ scm_i_dynwinds ());
+ scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
if (SCM_PROMPT_SETJMP (prompt))
{
/* The prompt exited nonlocally. Cache the regs back from the vp, and go
to the handler.
+
+ Note, at this point, we must assume that any variable local to
+ vm_engine that can be assigned *has* been assigned. So we need to pull
+ all our state back from the ip/fp/sp.
*/
- CACHE_REGISTER (); /* Really we only need SP. FP and IP should be
- unmodified. */
- ip += offset;
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
NEXT;
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 85e0e7a..1420611 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -231,7 +231,7 @@ vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
static void
vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
- size_t n, SCM *argv)
+ size_t n, SCM *argv, scm_t_int64 vm_cookie)
{
struct scm_vm *vp;
struct scm_vm_cont *cp;
@@ -267,8 +267,6 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM
intwinds,
vp->fp = RELOC (cp->fp);
vp->ip = cp->mvra;
-#undef RELOC
-
/* now push args. ip is in a MV context. */
for (i = 0; i < n; i++)
{
@@ -278,14 +276,32 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM
intwinds,
vp->sp++;
*vp->sp = scm_from_size_t (n);
- /* Finally, rewind the dynamic state. */
+ /* Finally, rewind the dynamic state.
+
+ We have to treat prompts specially, because we could be rewinding the
+ dynamic state from a different thread, or just a different position on the
+ C and/or VM stack -- so we need to reset the jump buffers so that an abort
+ comes back here, with appropriately adjusted sp and fp registers. */
{
long delta = 0;
SCM newwinds = scm_i_dynwinds ();
for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
- newwinds = scm_cons (scm_car (intwinds), newwinds);
+ {
+ SCM x = scm_car (intwinds);
+ if (SCM_PROMPT_P (x))
+ /* the jmpbuf will be reset by our caller */
+ x = scm_c_make_prompt (SCM_PROMPT_TAG (x),
+ RELOC (SCM_PROMPT_REGISTERS (x)->fp),
+ RELOC (SCM_PROMPT_REGISTERS (x)->sp),
+ SCM_PROMPT_REGISTERS (x)->ip,
+ SCM_PROMPT_ESCAPE_P (x),
+ vm_cookie,
+ newwinds);
+ newwinds = scm_cons (x, newwinds);
+ }
scm_dowinds (newwinds, delta);
}
+#undef RELOC
}
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a01e6be..1c13d70 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -40,6 +40,157 @@
(eval-when (compile)
(set-current-module (resolve-module '(guile))))
+
+
+;;; {Error handling}
+;;;
+
+;; Define delimited continuation operators, and implement catch and throw in
+;; terms of them.
+
+(define (prompt tag thunk handler)
+ (@prompt tag (thunk) handler))
+(define (abort tag . args)
+ (@abort tag args))
+
+
+
+;; Define catch and with-throw-handler, using some common helper routines and a
+;; shared fluid. Hide the helpers in a lexical contour.
+
+(let ()
+ ;; Ideally we'd like to be able to give these default values for all threads,
+ ;; even threads not created by Guile; but alack, that does not currently seem
+ ;; possible. So wrap the getters in thunks.
+ (define %running-exception-handlers (make-fluid))
+ (define %exception-handler (make-fluid))
+
+ (define (running-exception-handlers)
+ (or (fluid-ref %running-exception-handlers)
+ (begin
+ (fluid-set! %running-exception-handlers '())
+ '())))
+ (define (exception-handler)
+ (or (fluid-ref %exception-handler)
+ (begin
+ (fluid-set! %exception-handler default-exception-handler)
+ default-exception-handler)))
+
+ (define (default-exception-handler k . args)
+ (cond
+ ((eq? k 'quit)
+ (primitive-exit (cond
+ ((not (pair? args)) 0)
+ ((integer? (car args)) (car args))
+ ((not (car args)) 1)
+ (else 0))))
+ (else
+ (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
+ (primitive-exit 1))))
+
+ (define (default-throw-handler prompt-tag catch-k)
+ (let ((prev (exception-handler)))
+ (lambda (thrown-k . args)
+ (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+ (apply abort prompt-tag thrown-k args)
+ (apply prev thrown-k args)))))
+
+ (define (custom-throw-handler prompt-tag catch-k pre)
+ (let ((prev (exception-handler)))
+ (lambda (thrown-k . args)
+ (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+ (let ((running (running-exception-handlers)))
+ (with-fluids ((%running-exception-handlers (cons pre running)))
+ (if (not (memq pre running))
+ (apply pre thrown-k args))
+ ;; fall through
+ (if prompt-tag
+ (apply abort prompt-tag thrown-k args)
+ (apply prev thrown-k args))))
+ (apply prev thrown-k args)))))
+
+ (define! 'catch
+ ;; Until we get optargs support into Guile's C evaluator, we have to fake
it
+ ;; here.
+ (lambda (k thunk handler . pre-unwind-handler)
+ "Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}. If thunk throws to the symbol
address@hidden, then @var{handler} is invoked this way:
address@hidden
+ (handler key args ...)
address@hidden lisp
+
address@hidden is a symbol or @code{#t}.
+
address@hidden takes no arguments. If @var{thunk} returns
+normally, that is the return value of @code{catch}.
+
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
+
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
+
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
address@hidden before unwinding the dynamic state and
+invoking the main @var{handler}. @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}. It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
+
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler. If it exits
+non-locally, that exit determines the continuation."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error "catch" 'wrong-type-arg
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (let ((tag (gensym)))
+ (prompt tag
+ (lambda ()
+ (with-fluids
+ ((%exception-handler
+ (if (null? pre-unwind-handler)
+ (default-throw-handler tag k)
+ (custom-throw-handler tag k
+ (car pre-unwind-handler)))))
+ (thunk)))
+ (lambda (cont k . args)
+ (apply handler k args))))))
+
+ (define! 'with-throw-handler
+ (lambda (k thunk pre-unwind-handler)
+ "Add @var{handler} to the dynamic context as a throw handler
+for key @var{key}, then invoke @var{thunk}."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error "with-throw-handler" 'wrong-type-arg
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (with-fluids ((%exception-handler
+ (custom-throw-handler #f k pre-unwind-handler)))
+ (thunk))))
+
+ (define! 'throw
+ (lambda (key . args)
+ "Invoke the catch form matching @var{key}, passing @var{args} to the
address@hidden
+
address@hidden is a symbol. It will match catches of the same symbol or of
@code{#t}.
+
+If there is no handler at all, Guile prints an error and then exits."
+ (if (not (symbol? key))
+ ((exception-handler) 'wrong-type-arg "throw"
+ "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
+ (apply (exception-handler) key args)))))
+
+
+
+
;;; {R4RS compliance}
;;;
@@ -401,12 +552,6 @@
(define (and=> value procedure) (and value (procedure value)))
(define call/cc call-with-current-continuation)
-;;; Delimited continuations
-(define (prompt tag thunk handler)
- (@prompt tag (thunk) handler))
-(define (abort tag . args)
- (@abort tag args))
-
;;; apply-to-args is functionally redundant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
;;;
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index 650f255..d3fd1b3 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -204,3 +204,14 @@
(equal? (k) 1))
(pass-if "post"
(equal? (fluid-ref fl) 0))))
+
+(with-test-prefix "rewinding prompts"
+ (pass-if "nested prompts"
+ (let ((k (% 'a
+ (% 'b
+ (begin
+ (abort 'a)
+ (abort 'b #t))
+ (lambda (k x) x))
+ (lambda (k) k))))
+ (k))))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index c253b2d..fd5d750 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010 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
@@ -306,21 +306,19 @@
exception:wrong-type-arg
(+ (delay (* 3 7)) 13))
- ;; Tests that require the debugging evaluator...
- (with-debugging-evaluator
-
- (pass-if "unmemoizing a promise"
- (display-backtrace
- (let ((stack #f))
- (false-if-exception (lazy-catch #t
- (lambda ()
- (let ((f (lambda (g) (delay (g)))))
- (force (f error))))
- (lambda _
- (set! stack (make-stack #t)))))
- stack)
- (%make-void-port "w"))
- #t))))
+ (pass-if "unmemoizing a promise"
+ (display-backtrace
+ (let ((stack #f))
+ (false-if-exception
+ (with-throw-handler #t
+ (lambda ()
+ (let ((f (lambda (g) (delay (g)))))
+ (force (f error))))
+ (lambda _
+ (set! stack (make-stack #t)))))
+ stack)
+ (%make-void-port "w"))
+ #t)))
;;;
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index c2ec5f4..bcaa282 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -1,5 +1,5 @@
;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*-
-;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 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
@@ -75,9 +75,9 @@
(lambda () (throw 'a))
(lambda (x y . rest) #f))))
- (with-test-prefix "with lazy handler"
+ (with-test-prefix "with pre-unwind handler"
- (pass-if "lazy fluid state"
+ (pass-if "pre-unwind fluid state"
(equal? '(inner outer arg)
(let ((fluid-parm (make-fluid))
(inner-val #f))
@@ -102,32 +102,34 @@
(lambda (key . args)
(push 2))))
- (throw-test "catch and lazy catch"
+ (throw-test "catch and with-throw-handler"
'(1 2 3 4)
(catch 'a
(lambda ()
(push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (throw 'a))
- (lambda (key . args)
- (push 3))))
+ (with-throw-handler
+ 'a
+ (lambda ()
+ (push 2)
+ (throw 'a))
+ (lambda (key . args)
+ (push 3))))
(lambda (key . args)
(push 4))))
- (throw-test "catch with rethrowing lazy catch handler"
+ (throw-test "catch with rethrowing throw-handler"
'(1 2 3 4)
(catch 'a
(lambda ()
(push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (throw 'a))
- (lambda (key . args)
- (push 3)
- (apply throw key args))))
+ (with-throw-handler
+ 'a
+ (lambda ()
+ (push 2)
+ (throw 'a))
+ (lambda (key . args)
+ (push 3)
+ (apply throw key args))))
(lambda (key . args)
(push 4))))
@@ -183,27 +185,6 @@
(lambda (key . args)
(push 4))))
- (throw-test "effect of lazy-catch unwinding on throw to another key"
- '(1 2 3 5 7)
- (catch 'a
- (lambda ()
- (push 1)
- (lazy-catch 'b
- (lambda ()
- (push 2)
- (catch 'a
- (lambda ()
- (push 3)
- (throw 'b))
- (lambda (key . args)
- (push 4))))
- (lambda (key . args)
- (push 5)
- (throw 'a)))
- (push 6))
- (lambda (key . args)
- (push 7))))
-
(throw-test "effect of with-throw-handler not-unwinding on throw to another
key"
'(1 2 3 5 4 6)
(catch 'a
@@ -225,27 +206,6 @@
(lambda (key . args)
(push 7))))
- (throw-test "lazy-catch chaining"
- '(1 2 3 4 6 8)
- (catch 'a
- (lambda ()
- (push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (lazy-catch 'a
- (lambda ()
- (push 3)
- (throw 'a))
- (lambda (key . args)
- (push 4)))
- (push 5))
- (lambda (key . args)
- (push 6)))
- (push 7))
- (lambda (key . args)
- (push 8))))
-
(throw-test "with-throw-handler chaining"
'(1 2 3 4 6 8)
(catch 'a
@@ -267,48 +227,6 @@
(lambda (key . args)
(push 8))))
- (throw-test "with-throw-handler inside lazy-catch"
- '(1 2 3 4 6 8)
- (catch 'a
- (lambda ()
- (push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (with-throw-handler 'a
- (lambda ()
- (push 3)
- (throw 'a))
- (lambda (key . args)
- (push 4)))
- (push 5))
- (lambda (key . args)
- (push 6)))
- (push 7))
- (lambda (key . args)
- (push 8))))
-
- (throw-test "lazy-catch inside with-throw-handler"
- '(1 2 3 4 6 8)
- (catch 'a
- (lambda ()
- (push 1)
- (with-throw-handler 'a
- (lambda ()
- (push 2)
- (lazy-catch 'a
- (lambda ()
- (push 3)
- (throw 'a))
- (lambda (key . args)
- (push 4)))
- (push 5))
- (lambda (key . args)
- (push 6)))
- (push 7))
- (lambda (key . args)
- (push 8))))
-
(throw-test "throw handlers throwing to each other recursively"
'(1 2 3 4 8 6 10 12)
(catch #t
@@ -340,37 +258,6 @@
(lambda (key . args)
(push 12))))
- (throw-test "repeat of previous test but with lazy-catch"
- '(1 2 3 4 8 12)
- (catch #t
- (lambda ()
- (push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (lazy-catch 'b
- (lambda ()
- (push 3)
- (lazy-catch 'c
- (lambda ()
- (push 4)
- (throw 'b)
- (push 5))
- (lambda (key . args)
- (push 6)
- (throw 'a)))
- (push 7))
- (lambda (key . args)
- (push 8)
- (throw 'c)))
- (push 9))
- (lambda (key . args)
- (push 10)
- (throw 'b)))
- (push 11))
- (lambda (key . args)
- (push 12))))
-
(throw-test "throw handler throwing to lexically inside catch"
'(1 2 7 5 4 6 9)
(with-throw-handler 'a
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-8-50-gadbdfd6,
Andy Wingo <=