This is the mail archive of the kawa@sourceware.org mailing list for the Kawa project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

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))

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]