diff options
author | Andy Wingo <wingo@pobox.com> | 2011-03-24 20:20:14 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-03-30 12:43:50 +0200 |
commit | e309f3bf9ee910c4772353ca3ff95f6f4ef466b5 (patch) | |
tree | 3ae369afe2f8806931b93391eed22e8e4a6b1a28 | |
parent | 653ccd78fa6770c692f5a737ad70de5aedbfcc7f (diff) | |
download | guile-e309f3bf9ee910c4772353ca3ff95f6f4ef466b5.tar.gz |
with-continuation-barrier calls exit(3) _after_ unwinding
* libguile/continuations.c (scm_handler, c_handler)
(scm_c_with_continuation_barrier, scm_with_continuation_barrier):
Instead of calling scm_handle_by_message_noexit in the pre-unwind
handler, roll our own exception printing in the pre-unwind, and do to
exit()-on-quit in the post-unwind handler. This lets the stack unwind
at exit-time so that pending dynwinds run.
* test-suite/tests/continuations.test ("continuations"): Add a test.
-rw-r--r-- | libguile/continuations.c | 67 | ||||
-rw-r--r-- | test-suite/tests/continuations.test | 13 |
2 files changed, 76 insertions, 4 deletions
diff --git a/libguile/continuations.c b/libguile/continuations.c index dc6850e05..7d56c2a59 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -460,6 +460,45 @@ scm_i_with_continuation_barrier (scm_t_catch_body body, return result; } + + +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); +} + + + struct c_data { void *(*func) (void *); void *data; @@ -477,11 +516,27 @@ c_body (void *d) 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) { @@ -490,7 +545,8 @@ 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; } @@ -508,6 +564,10 @@ scm_body (void *d) 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; } @@ -529,7 +589,8 @@ SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0, 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 diff --git a/test-suite/tests/continuations.test b/test-suite/tests/continuations.test index f6db40e58..a436b90d4 100644 --- a/test-suite/tests/continuations.test +++ b/test-suite/tests/continuations.test @@ -1,7 +1,7 @@ ;;;; -*- 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 @@ -80,6 +80,17 @@ (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" |