Hi all, I have some lines of Scheme, which rely on SRF-34 and I don't really want to change that code.
I can hardly imagine, that I can't replace chickens exception handler. But I can't. What I tried was to overwrite ##sys#error and friends (see appended source - which does not really get the job done). [The next step is going to be funny formating and routing of those exceptions. So I *really* need to get them under control. So how would I plug my exception handler in place of the standard exception handler? Thanks a lot
;; (C) 2008 Joerg F. Wittenberger see http://www.askemos.org (declare (unit cndtnhndlng) (uses srfi-1 srfi-13 srfi-18 library) (fixnum-arithmetic) (disable-warning var redef) (not usual-integrations raise signal error current-exception-handler) (export make-condition-type condition-type? condition-type-name condition-types make-condition condition? condition-has-type? condition-ref make-compound-condition extract-condition &condition &message message-condition? condition-message &serious serious-condition? &error error? type-field-alist->condition check-condition-type-field-alist) (export with-exception-guard raise signal error abort ##sys#error ##sys#signal current-exception-handler with-exception-handler ) ) ;(include "srfi34-syntax.scm") ;; REPLACE THE EXCEPTION HANDLER ;; unsure, shouldn't we wrap the handler with dynamic-wind ? (define chicken-exception-handler (current-exception-handler)) (define srfi34:*current-exception-handlers* (make-parameter (list chicken-exception-handler))) (define (srfi34:with-exception-handler handler thunk) (srfi34:with-exception-handlers (cons handler (srfi34:*current-exception-handlers*)) thunk)) (define (srfi34:with-exception-handlers new-handlers thunk) (let ((previous-handlers (srfi34:*current-exception-handlers*))) (dynamic-wind (lambda () (srfi34:*current-exception-handlers* new-handlers)) thunk (lambda () (srfi34:*current-exception-handlers* previous-handlers))))) (define (srfi34:raise obj) (let ((handlers (srfi34:*current-exception-handlers*))) (srfi34:with-exception-handlers (cdr handlers) (lambda () ((car handlers) obj) ;; (error "handler returned" (car handlers) obj) (chicken-exception-handler (make-property-condition 'exn 'message "exception handler returned")))))) (set! with-exception-handler srfi34:with-exception-handler) (set! current-exception-handler (lambda () (car (srfi34:*current-exception-handlers*)))) (set! ##sys#default-exception-handler current-exception-handler) ; (define (##sys#escape x) ; (let ((handler-chain ##sys#current-exception-handler)) ; (set! ##sys#current-exception-handler ; (cdr ##sys#current-exception-handler)) ; ((car handler-chain) x) ; (set! ##sys#current-exception-handler handler-chain))) ;(define srfi-34:raise ##sys#escape) (set! ##sys#abort (lambda (x) ((car (srfi34:*current-exception-handlers*)) x) (##sys#abort (make-property-condition 'exn 'message "exception handler returned")) )) (set! ##sys#signal (lambda (x) ((car (srfi34:*current-exception-handlers*)) x)) ) (set! ##sys#current-exception-handler current-exception-handler) (define raise srfi34:raise) (set! abort ##sys#abort) (set! signal ##sys#signal) (set! error (lambda (msg . args) (let ((s (if (pair? args) (format #f "~a ~s" msg args) msg))) (if (enable-warnings) (##sys#signal-hook #:warning s)) (srfi34:raise s)))) (set! ##sys#error error) ; (set! ##sys#current-exception-handler ; (list ##sys#current-exception-handler)) ; (set! with-exception-handler ; (lambda (handler thunk) ; (let ((handler-chain ##sys#current-exception-handler)) ; (##sys#dynamic-wind ; (lambda () (set! ##sys#current-exception-handler ; (cons handler handler-chain))) ; thunk ; (lambda () (set! ##sys#current-exception-handler handler-chain)) ))) ) ;; SRFI 34 support (define (with-exception-guard handler thunk) ((call-with-current-continuation (lambda (return) (srfi34:with-exception-handler (lambda (condition) ((call-with-current-continuation (lambda (handler-k) (return (lambda () (srfi34:with-exception-handler (lambda (condition) (handler-k (lambda () (srfi34:raise condition)))) (lambda () (handler condition))))))))) (lambda () (##sys#call-with-values thunk (lambda args (return (lambda () (##sys#apply ##sys#values args)))) ) ) ) ) )) ) ;; SRFI 35 reference implementation (define-record-type :condition-type (really-make-condition-type name supertype fields all-fields) condition-type? (name condition-type-name) (supertype condition-type-supertype) (fields condition-type-fields) (all-fields condition-type-all-fields)) (define (make-condition-type name supertype fields) (if (not (symbol? name)) (error "make-condition-type: name is not a symbol" name)) (if (not (condition-type? supertype)) (error "make-condition-type: supertype is not a condition type" supertype)) (if (not (null? (lset-intersection eq? (condition-type-all-fields supertype) fields))) (error "duplicate field name" )) (really-make-condition-type name supertype fields (append (condition-type-all-fields supertype) fields))) (define (condition-subtype? subtype supertype) (let recur ((subtype subtype)) (cond ((not subtype) #f) ((eq? subtype supertype) #t) (else (recur (condition-type-supertype subtype)))))) (define (condition-type-field-supertype condition-type field) (let loop ((condition-type condition-type)) (cond ((not condition-type) #f) ((memq field (condition-type-fields condition-type)) condition-type) (else (loop (condition-type-supertype condition-type)))))) ; The type-field-alist is of the form ; ((<type> (<field-name> . <value>) ...) ...) (define-record-type :condition (really-make-condition type-field-alist) condition?* (type-field-alist condition-type-field-alist)) (define chicken-condition? condition?) (define condition? (let ((orig condition?)) (lambda (obj) (or (condition?* obj) (orig obj))))) (define (make-condition type . field-plist) (let ((alist (let label ((plist field-plist)) (if (null? plist) '() (cons (cons (car plist) (cadr plist)) (label (cddr plist))))))) (if (not (lset= eq? (condition-type-all-fields type) (map car alist))) (error "condition fields don't match condition type")) (really-make-condition (list (cons type alist))))) (define (condition-has-type? condition type) (and (condition?* condition) (any (lambda (has-type) (condition-subtype? has-type type)) (condition-types condition)))) (define (condition-ref condition field) (type-field-alist-ref (condition-type-field-alist condition) field)) (define (type-field-alist-ref type-field-alist field) (let loop ((type-field-alist type-field-alist)) (cond ((null? type-field-alist) (error "type-field-alist-ref: field not found" type-field-alist field)) ((assq field (cdr (car type-field-alist))) => cdr) (else (loop (cdr type-field-alist)))))) (define (make-compound-condition condition-1 . conditions) (really-make-condition (apply append (map condition-type-field-alist (cons condition-1 conditions))))) (define (extract-condition condition type) (let ((entry (find (lambda (entry) (condition-subtype? (car entry) type)) (condition-type-field-alist condition)))) (if (not entry) (error "extract-condition: invalid condition type" condition type)) (really-make-condition (list (cons type (map (lambda (field) (assq field (cdr entry))) (condition-type-all-fields type))))))) (define (type-field-alist->condition type-field-alist) (really-make-condition (map (lambda (entry) (cons (car entry) (map (lambda (field) (or (assq field (cdr entry)) (cons field (type-field-alist-ref type-field-alist field)))) (condition-type-all-fields (car entry))))) type-field-alist))) (define (condition-types condition) (if (condition?* condition) (map car (condition-type-field-alist condition)) '())) (define (check-condition-type-field-alist the-type-field-alist) (let loop ((type-field-alist the-type-field-alist)) (if (not (null? type-field-alist)) (let* ((entry (car type-field-alist)) (type (car entry)) (field-alist (cdr entry)) (fields (map car field-alist)) (all-fields (condition-type-all-fields type))) (for-each (lambda (missing-field) (let ((supertype (condition-type-field-supertype type missing-field))) (if (not (any (lambda (entry) (let ((type (car entry))) (condition-subtype? type supertype))) the-type-field-alist)) (error "missing field in condition construction" type missing-field)))) (lset-difference eq? all-fields fields)) (loop (cdr type-field-alist)))))) (define &condition (really-make-condition-type '&condition #f '() '())) (define-condition-type &message &condition message-condition? (message condition-message)) (define-condition-type &serious &condition serious-condition?) (define-condition-type &error &serious error?)
_______________________________________________ Chicken-users mailing list [email protected] http://lists.nongnu.org/mailman/listinfo/chicken-users
