return result;
}
+\f
+
+static int
+should_print_backtrace (SCM tag, SCM stack)
+{
+ return SCM_BACKTRACE_P
+ && scm_is_true (stack)
+ && scm_initialized_p
+ /* It's generally not useful to print backtraces for errors reading
+ or expanding code in these fallback catch statements. */
+ && !scm_is_eq (tag, scm_from_latin1_symbol ("read-error"))
+ && !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"));
+}
+
+static void
+print_exception_and_backtrace (SCM port, SCM tag, SCM args)
+{
+ SCM stack, frame;
+
+ /* We get here via a throw to a catch-all. In that case there is the
+ throw frame active, and this catch closure, so narrow by two
+ frames. */
+ stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+ frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
+
+ if (should_print_backtrace (tag, stack))
+ {
+ scm_puts ("Backtrace:\n", port);
+ scm_display_backtrace_with_highlights (stack, port,
+ SCM_BOOL_F, SCM_BOOL_F,
+ SCM_EOL);
+ scm_newline (port);
+ }
+
+ scm_print_exception (port, frame, tag, args);
+}
+
+\f
+
struct c_data {
void *(*func) (void *);
void *data;
static SCM
c_handler (void *d, SCM tag, SCM args)
{
- struct c_data *data = (struct c_data *)d;
+ struct c_data *data;
+
+ /* If TAG is `quit', exit() the process. */
+ if (scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
+ exit (scm_exit_status (args));
+
+ data = (struct c_data *)d;
data->result = NULL;
return SCM_UNSPECIFIED;
}
+static SCM
+pre_unwind_handler (void *error_port, SCM tag, SCM args)
+{
+ /* Print the exception unless TAG is `quit'. */
+ if (!scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
+ print_exception_and_backtrace (PTR2SCM (error_port), tag, args);
+
+ return SCM_UNSPECIFIED;
+}
+
void *
scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
{
c_data.data = data;
scm_i_with_continuation_barrier (c_body, &c_data,
c_handler, &c_data,
- scm_handle_by_message_noexit, NULL);
+ pre_unwind_handler,
+ SCM2PTR (scm_current_error_port ()));
return c_data.result;
}
static SCM
scm_handler (void *d, SCM tag, SCM args)
{
+ /* Print a message. Note that if TAG is `quit', this will exit() the
+ process. */
+ scm_handle_by_message_noexit (NULL, tag, args);
+
return SCM_BOOL_F;
}
scm_data.proc = proc;
return scm_i_with_continuation_barrier (scm_body, &scm_data,
scm_handler, &scm_data,
- scm_handle_by_message_noexit, NULL);
+ pre_unwind_handler,
+ SCM2PTR (scm_current_error_port ()));
}
#undef FUNC_NAME
;;;; -*- scheme -*-
;;;; continuations.test --- test suite for continutations
;;;;
-;;;; Copyright (C) 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2009, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(error "Catch me if you can!")))))))))
handled))
+ (pass-if "exit unwinds dynwinds inside a continuation barrier"
+ (let ((s (with-error-to-string
+ (lambda ()
+ (with-continuation-barrier
+ (lambda ()
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () (exit 1))
+ (lambda () (throw 'abcde)))))))))
+ (and (string-contains s "abcde") #t)))
+
(with-debugging-evaluator
(pass-if "make a stack from a continuation"