This is the mail archive of the
kawa@sourceware.org
mailing list for the Kawa project.
Re: R6RS exceptions
* Per Bothner [2008-03-15 23:43+0100] writes:
> Re-implementing guard becomes a bit tricky. The reference
> implementation uses call-with-current-continuation. That
> might work (it looks like it only needs the continuation
> support that kawa provides), but ugly and inefficient.
This is indeed tricky. R6RS says:
Evaluating a guard form evaluates <body> with an exception handler
that binds the raised object to <variable> and within the scope of
that binding evaluates the clauses as if they were the clauses of a
cond expression. That implicit cond expression is evaluated with the
continuation and dynamic environment of the guard expression. If every
<cond clause>'s <test> evaluates to #f and there is no else clause,
then raise is re-invoked on the raised object within the dynamic
environment of the original call to raise except that the current
exception handler is that of the guard expression.
Re-invoking raise in the original environment sounds difficult to do if
the tests should be evaluated in the environment of guard.
> If you want to try to get something based on these idea working,
> it would be much appreciated. Otherwise, I'll put it on my
> list, and try to get to it when I get a chance.
Well, I tried. Instead of evaluating the guard tests in the environment
of guard I evaluate them in the dynamic environment of the handler. The
<expressions> of the <cond clause> is evaluated in the environment of
guard. E.g.
(guard (c ((integer? c) 'int)
((pair? c) 'pair)
((vector? c) 'vector))
(raise x))
expands to something like this:
(let ()
(define handler
(lambda (c)
(let ((k
(cond ((integer? c) 0)
((pair? c) (+ 0 1))
((vector? c) (+ (+ 0 1) 1))
(else -1))))
(cond ((= k -1) (raise-continuable c))
(else (primitive-throw (<guard-matched> c k handler))))))
(try-catch
(parameterize
((current-exception-handlers (cons handler (current-exception-handlers))))
(raise x))
(ex
<guard-matched>
(if (eq? (slot-ref ex (quote handler)) handler)
(let ((c (slot-ref ex (quote condition))) (k (slot-ref ex (quote k))))
(cond ((= k 0) (quote int))
((= k (+ 0 1)) (quote pair))
((= k (+ (+ 0 1) 1)) (quote vector))))
(primitive-throw ex)))))
The implementation and some tests are attached below. Unfortunately I
get an nullpointer exception if I enable the module-export clause.
Helmut.
(module-compile-options warn-undefined-variable: #t
warn-invoke-unknown-method: #t)
;;(module-export with-exception-handler raise guard)
(provide 'srfi-34)
(define-simple-class &condition ())
(define-simple-class &serious (&condition))
(define (serious-condition? o) (instance? o &serious))
(define-simple-class &violation (&serious))
(define (violation? o) (instance? o &violation))
(define-simple-class &non-continuable (&violation)
(condition)
((*init* c) (set! (this):condition c)))
(define (non-continuable-violation? o) (instance? o &violation))
(define-simple-class <no-handler-exception> (<java.lang.RuntimeException>)
(condition)
((*init* c) (set! (this):condition c)))
(define (handle-unhandled c)
(cond ((serious-condition? c)
(format (current-error-port)
"No handler for: ~s~%The party is over!~%" c)
(primitive-throw (<no-handler-exception> c)))
(else
;; just return
#f)))
(define current-exception-handlers (make-parameter (list handle-unhandled)))
(define (raise-continuable obj)
(let ((handlers (current-exception-handlers)))
(parameterize ((current-exception-handlers (cdr handlers)))
((car handlers) obj))))
(define (raise obj)
(let ((handlers (current-exception-handlers)))
(parameterize ((current-exception-handlers (cdr handlers)))
((car handlers) obj)
(handle-non-continuable obj))))
(define (handle-non-continuable o)
(let ((c (&non-continuable o)))
(cond ((null? (current-exception-handlers))
(handle-unhandled c))
(else
(raise c)))))
(define-syntax with-exception-handler%
(syntax-rules ()
((with-exception-handler% handler body ...)
;; Should we handle arbitrary Throwables? Probably.
(parameterize ((current-exception-handlers
(cons handler (current-exception-handlers))))
body ...))))
(define (with-exception-handler handler thunk)
(with-exception-handler% handler (thunk)))
(define-simple-class <guard-matched> (<java.lang.Throwable>)
(condition)
(k :: <int>)
(handler)
((*init* condition (k :: <int>) handler)
(set! (this):condition condition)
(set! (this):k k)
(set! (this):handler handler)))
(define-syntax guard-test%
(syntax-rules (else)
((guard-test% i) -1)
((guard-test% i else) i)
((guard-test% i test tests ...)
(if test i (guard-test% (+ i 1) tests ...)))))
(define-syntax guard-case%
(syntax-rules ()
((guard-case% k i (clause ...))
(if (= k i) (begin clause ...)))
((guard-case% k i (clause ...) clauses ...)
(if (= k i) (begin clause ...) (guard-case% k (+ i 1) clauses ...)))))
(define-syntax guard
(syntax-rules ()
((guard (var) body ...) (begin body ...))
((guard (var (test clause ...) ...) body ...)
(letrec ((handler
(lambda (var)
(let ((k (guard-test% 0 test ...)))
(cond ((= k -1)
(raise-continuable var))
(else
(primitive-throw
(<guard-matched> var k handler))))))))
(try-catch
(with-exception-handler% handler body ...)
(ex <guard-matched>
(cond ((eq? ex:handler handler)
(let ((var ex:condition) (k :: <int> ex:k))
(guard-case% k 0 (clause ...) ...)))
(else (primitive-throw ex)))))))))
(test-init "R6RS Exceptions")
(require 'srfi-34)
(test 'int 'simple-guard (guard (c ((integer? c) 'int))
(raise 10)))
(test 'int 'simple-guard
(guard (c ((pair? c) 'pair)
((integer? c) 'int))
(raise 10)))
(test 'int 'nested-guard
(guard (c ((pair? c) 'pair)
((integer? c) 'int))
(guard (c ((pair? c) 'cons))
(raise 10))))
(test 'cons 'nested-guard
(guard (c ((pair? c) 'pair)
((integer? c) 'int))
(guard (c ((pair? c) 'cons))
(raise (cons 1 2)))))
(test 'else 'guard-else
(guard (c (else 'else))
(raise 19)))
(test 'bar 'with-handler
(let ((p (make-parameter 'foo))
(result #f))
(with-exception-handler (lambda (_) (set! result (p)))
(lambda ()
(parameterize ((p 'bar))
(raise-continuable 'abort))))
result))
(test 'foo 'guard-extend
(let ((p (make-parameter 'foo))
(result #f))
(guard (c (#t (set! result (p))))
(parameterize ((p 'bar))
(raise-continuable 'abort)))
result))
(set! fail-expected
"Guard tests aren't executed in the dynamic environment of guard.")
(test 'foo 'guard-extend
(let ((p (make-parameter 'foo))
(result #f))
(guard (c ((set! result (p)) #f))
(parameterize ((p 'bar))
(raise-continuable 'abort)))
result))