implementation problems

[Richard Kelsey <kelsey@xxxxxxx>]

In a posting to comp.lang.scheme (**) Henrik Tidefelt pointed out that
the following doesn't work properly using the reference implementation.
It loops indefinitely instead of calling the initial exception handler.

  (guard (ball
          (#f (display "Caught exception.")))
         (guard (ball
                 (#f (raise ball)))
                (raise 'exn)))

When trying to fix this I noticed that the reference implementation doesn't
implement the SRFI as specified.  It goes to some effort to call a handler
in the dynamic environment of the WITH-HANDLER call that installed it
instead of using the dynamic environment of the call to RAISE, which is
what is required.  It's a bug in the dynamic environment manipulation that
causes the behavior that Tidefelt noticed.

Oops.

I believe that the following code is a correct implemenation of SRFI 34.
It works for the examples in the SRFI and Tidefelt's code, as well as some
tests that check that handlers are called with the correct dynamic
environment.
                                  -Richard Kelsey

(define *current-exception-handlers*
  (list (lambda (condition)
          (error "unhandled exception" condition))))

(define (with-exception-handler handler thunk)
  (with-exception-handlers (cons handler *current-exception-handlers*)
                           thunk))

(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 (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
  ... as in the original ...)


** http://groups.google.com/groups?selm=henti634-608755.01551322022003%40newsc.telia.net