[Chicken-users] srfi-34

[F. Wittenberger]

I found the srfi-34 egg not working nice together with srfi-18 and when
mixed with chicken's exceptions.

Find attached an implementation, which fixes this.


;; (C) 2008, 2010 Joerg F. Wittenberger see http://www.askemos.org

;; Try to be nice and mix+match with chickens native error handling.
;; Could probably be much mor efficient if we did not do so.

(declare
 (unit srfi-34)
 (fixnum-arithmetic)
 (disable-interrupts)
 (usual-integrations)

 (no-bound-checks)
 (no-procedure-checks-for-usual-bindings)
 (bound-to-procedure
  ##sys#current-exception-handler
  ##sys#check-symbol ##sys#symbol->string symbol->string
  ##sys#make-structure ##sys#structure? ##sys#check-structure)
 )

(module
 srfi-34
 (
  guard
  with-exception-handler
  with-exception-guard
  raise
  )

 (import scheme (only chicken make-parameter) (prefix srfi-18 s18:) (prefix chicken s18:))

 (define (error msg . args)
   (##sys#abort
    (##sys#make-structure
     'condition
     '(exn) 
     (list '(exn . message) msg
	   '(exn . arguments) args
	   '(exn . location) #f) ) ))

 (define *current-exception-handlers*
  (make-parameter
   (list ##sys#current-exception-handler)))

 (define (with-exception-handlers new-handlers thunk)
   (let ((previous-handlers (*current-exception-handlers*))
	 [oldh ##sys#current-exception-handler])
     (dynamic-wind
	 (lambda ()
	   (set! ##sys#current-exception-handler ##sys#raise)
	   (*current-exception-handlers* new-handlers))
	 thunk
	 (lambda ()
	   (set! ##sys#current-exception-handler oldh)
	   (*current-exception-handlers* previous-handlers)))))

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

 (define (##sys#raise obj)
   (let ((handlers (*current-exception-handlers*)))
     (with-exception-handlers (cdr handlers)
      (lambda ()
	((car handlers) obj)
	(error "handler returned"
	       (car handlers)
	       obj)))))

 (define raise ##sys#raise)

 (set! ##sys#current-exception-handler ##sys#raise)
 (set! s18:with-exception-handler with-exception-handler)

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

; (define raise s18:raise)

 (define (with-exception-guard handler thunk)
   ((call-with-current-continuation
     (lambda (return)
       (let ((oldh (s18:current-exception-handler)))
	 (with-exception-handler
	  (lambda (condition)
	    (with-exception-handler
	     oldh
	     (call-with-current-continuation
	      (lambda (handler-k)
		(return (lambda () (handler condition)))))))
	  (lambda ()
	    (##sys#call-with-values
	     thunk
	     (lambda args
	       (return (lambda () (##sys#apply ##sys#values args)))) ) ) )) ) )) )

 )

_______________________________________________
Chicken-users mailing list
Chicken-users@nongnu.org
http://lists.nongnu.org/mailman/listinfo/chicken-users