79 lines
2.5 KiB
Scheme
79 lines
2.5 KiB
Scheme
|
(define *current-exception-handlers*
|
||
|
|
(list (lambda (condition)
|
||
|
|
(error "*current-exception-handler*" "unhandled exception" condition))))
|
||
|
|
|
||
|
|
(define (with-exception-handlers new-handlers thunk)
|
||
|
|
(let ((previous-handlers *current-exception-handlers*))
|
||
|
|
(dynamic-wind
|
||
|
|
(lambda ()
|
||
|
|
(set! *current-exception-handlers* new-handlers))
|
||
|
|
thunk
|
||
|
|
(lambda ()
|
||
|
|
(set! *current-exception-handlers* previous-handlers)))))
|
||
|
|
|
||
|
|
(define (with-exception-handler handler thunk)
|
||
|
|
(with-exception-handlers (cons handler *current-exception-handlers*)
|
||
|
|
thunk))
|
||
|
|
|
||
|
|
(define (raise obj)
|
||
|
|
(let ((handlers *current-exception-handlers*))
|
||
|
|
(with-exception-handlers (cdr handlers)
|
||
|
|
(lambda ()
|
||
|
|
((car handlers) obj)
|
||
|
|
(error "handler returned"
|
||
|
|
(car handlers)
|
||
|
|
obj)))))
|
||
|
|
|
||
|
|
(define-syntax guard
|
||
|
|
(syntax-rules ()
|
||
|
|
((guard (var clause ...) e1 e2 ...)
|
||
|
|
((call-with-current-continuation
|
||
|
|
(lambda (guard-k)
|
||
|
|
(with-exception-handler
|
||
|
|
(lambda (condition)
|
||
|
|
((call-with-current-continuation
|
||
|
|
(lambda (handler-k)
|
||
|
|
(guard-k
|
||
|
|
(lambda ()
|
||
|
|
(let ((var condition)) ; clauses may SET! var
|
||
|
|
(guard-aux (handler-k (lambda ()
|
||
|
|
(raise 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))
|
||
|
|
test)
|
||
|
|
((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 ...)))))
|
||
|
|
|