53 lines
1.7 KiB
Scheme
53 lines
1.7 KiB
Scheme
|
(begin
|
||
|
|
|
||
|
|
(define current-exception-handlers
|
||
|
|
(let ((e error))
|
||
|
|
(make-parameter (list e))))
|
||
|
|
|
||
|
|
(define (raise x)
|
||
|
|
(let ((handlers (current-exception-handlers)))
|
||
|
|
(parameterize ((current-exception-handlers (cdr handlers)))
|
||
|
|
((car handlers) x)
|
||
|
|
(error "handler returned" x))))
|
||
|
|
|
||
|
|
(define (raise-continuable x)
|
||
|
|
(let ((handlers (current-exception-handlers)))
|
||
|
|
(parameterize ((current-exception-handlers (cdr handlers)))
|
||
|
|
((car handlers) x))))
|
||
|
|
|
||
|
|
(define (with-exception-handler handler thunk)
|
||
|
|
(let ((handlers (current-exception-handlers)))
|
||
|
|
(parameterize ((current-exception-handlers (cons handler handlers)))
|
||
|
|
(thunk))))
|
||
|
|
|
||
|
|
(define-record-type error-object
|
||
|
|
(make-error-object type message irritants)
|
||
|
|
error-object?
|
||
|
|
(type error-object-type)
|
||
|
|
(message error-object-message)
|
||
|
|
(irritants error-object-irritants))
|
||
|
|
|
||
|
|
(set! error
|
||
|
|
(lambda (message . irritants)
|
||
|
|
(raise (make-error-object #f message irritants))))
|
||
|
|
|
||
|
|
(set! display
|
||
|
|
(let ((d display))
|
||
|
|
(lambda (x . port)
|
||
|
|
(let ((port (if (null? port) (current-error-port) (car port))))
|
||
|
|
(if (error-object? x)
|
||
|
|
(let ()
|
||
|
|
(when (error-object-type x)
|
||
|
|
(d (error-object-type x) port)
|
||
|
|
(d "-" port))
|
||
|
|
(d "error: \"" port)
|
||
|
|
(d (error-object-message x) port)
|
||
|
|
(d "\"")
|
||
|
|
(for-each
|
||
|
|
(lambda (x)
|
||
|
|
(d " " port)
|
||
|
|
(write x port))
|
||
|
|
(error-object-irritants x))
|
||
|
|
(d "\n" port))
|
||
|
|
(apply d x port)))))))
|