~ chicken-r7rs (master) 8e3cd329195c5dd4853ca93d641808f903f17b8b
commit 8e3cd329195c5dd4853ca93d641808f903f17b8b
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Thu Jun 13 19:14:25 2013 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Thu Jun 13 19:14:25 2013 +0000
Fix with-exception-handler and guard; improve tests a bit
diff --git a/scheme.base.scm b/scheme.base.scm
index d6166c6..b2c2b90 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -37,69 +37,70 @@
;;;
;; guard & guard-aux copied verbatim from the draft.
+;; guard-aux put in a letrec-syntax due to import/export issues...
(define-syntax guard
(syntax-rules ()
((guard (var clause ...) e1 e2 ...)
- ((call/cc
+ (letrec-syntax ((guard-aux
+ (syntax-rules ___ (else =>)
+ ((guard-aux reraise (else result1 result2 ___))
+ (begin result1 result2 ___))
+ ((guard-aux reraise (test => result))
+ (let ((temp test))
+ (if temp
+ (result temp)
+ reraise)))
+ ((guard-aux reraise (test => result)
+ clause1 clause2 ___)
+ (let ((temp test))
+ (if temp
+ (result temp)
+ (guard-aux reraise clause1 clause2 ___))))
+ ((guard-aux reraise (test))
+ (or test reraise))
+ ((guard-aux reraise (test) clause1 clause2 ___)
+ (let ((temp test))
+ (if temp
+ temp
+ (guard-aux reraise clause1 clause2 ___))))
+ ((guard-aux reraise (test result1 result2 ___))
+ (if test
+ (begin result1 result2 ___)
+ reraise))
+ ((guard-aux reraise
+ (test result1 result2 ___)
+ clause1 clause2 ___)
+ (if test
+ (begin result1 result2 ___)
+ (guard-aux reraise clause1 clause2 ___))))))
+ ((call/cc
(lambda (guard-k)
(with-exception-handler
(lambda (condition)
((call/cc
- (lambda (handler-k)
- (guard-k
- (lambda ()
- (let ((var condition))
- (guard-aux
- (handler-k
- (lambda ()
- (raise-continuable condition)))
- clause ...))))))))
+ (lambda (handler-k)
+ (guard-k
+ (lambda ()
+ (let ((var condition))
+ (guard-aux
+ (handler-k
+ (lambda ()
+ (raise-continuable condition)))
+ clause ...))))))))
(lambda ()
(call-with-values
- (lambda () e1 e2 ...)
- (lambda args
- (guard-k
- (lambda ()
- (apply values args)))))))))))))
-
-(define-syntax guard-aux
- (syntax-rules (else =>)
- ((guard-aux reraise (else result1 result2 ...))
- (begin result1 result2 ...))
- ((guard-aux reraise (test => result))
- (let ((temp test))
- (if temp
- (result temp)
- reraise)))
- ((guard-aux reraise (test => result)
- clause1 clause2 ...)
- (let ((temp test))
- (if temp
- (result temp)
- (guard-aux reraise clause1 clause2 ...))))
- ((guard-aux reraise (test))
- (or test reraise))
- ((guard-aux reraise (test) clause1 clause2 ...)
- (let ((temp test))
- (if temp
- temp
- (guard-aux reraise clause1 clause2 ...))))
- ((guard-aux reraise (test result1 result2 ...))
- (if test
- (begin result1 result2 ...)
- reraise))
- ((guard-aux reraise
- (test result1 result2 ...)
- clause1 clause2 ...)
- (if test
- (begin result1 result2 ...)
- (guard-aux reraise clause1 clause2 ...)))))
+ (lambda () e1 e2 ...)
+ (lambda args
+ (guard-k
+ (lambda ()
+ (apply values args))))))))))))))
;;;
;;; 6.11. Exceptions
;;;
+;; XXX TODO: This is not threadsafe!
(define-values (with-exception-handler raise raise-continuable)
(let ((exception-handlers
(let ((lst (list ##sys#current-exception-handler)))
@@ -110,6 +111,11 @@
(lambda (handler thunk)
(dynamic-wind
(lambda ()
+ ;; We might be interoperating with srfi-12 handlers set by intermediate
+ ;; non-R7RS code, so check if a new handler was set in the meanwhile.
+ (unless (eq? (car exception-handlers) ##sys#current-exception-handler)
+ (set! exception-handlers
+ (cons ##sys#current-exception-handler exception-handlers)))
(set! exception-handlers (cons handler exception-handlers))
(set! ##sys#current-exception-handler handler))
thunk
diff --git a/tests/run.scm b/tests/run.scm
index a79a9c7..9201b30 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -3,6 +3,8 @@
(define (read-from-string s)
(with-input-from-string s read))
+(test-begin "r7rs tests")
+
(test-group "long boolean literals"
(test #t (read-from-string "#t"))
(test #f (read-from-string "#f"))
@@ -28,13 +30,16 @@
(lambda () (+ 1 (raise 'an-error)))))
(test-error "with-exception-handler (raise)"
(with-exception-handler
- (lambda (e) 'ignore)
+ (lambda (e) (raise 'another-error))
(lambda () (+ 1 (raise 'an-error)))))
(test "with-exception-handler (raise-continuable)"
- 65
- (with-exception-handler
- (lambda (e) 42)
- (lambda () (+ (raise-continuable "should be a number") 23))))
+ '("should be a number" 65)
+ (let* ((exception-object #f)
+ (return-value
+ (with-exception-handler
+ (lambda (e) (set! exception-object e) 42)
+ (lambda () (+ (raise-continuable "should be a number") 23)))))
+ (list exception-object return-value)))
(test "error-object? (#f)" #f (error-object? 'no))
(test "error-object? (#t)" #t (error-object? (catch (car '()))))
(test "error-object-message" "fubar" (error-object-message (catch (error "fubar"))))
@@ -110,3 +115,7 @@
(not (input-port-open? the-string-port)))
(test-assert "It's ok to close input ports that are already closed"
(close-port the-string-port)))))
+
+(test-end "r7rs tests")
+
+(test-exit)
Trap