93 lines
3.8 KiB
Scheme
93 lines
3.8 KiB
Scheme
|
;;; Handle fatal errors in a sensible way. -*- Scheme -*-
|
||
|
|
;;; Copyright (c) 1995 by Olin Shivers.
|
||
|
|
|
||
|
|
;;; (with-fatal-error-handler* handler thunk)
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Call THUNK, and return whatever it returns. If THUNK signals a condition,
|
||
|
|
;;; and that condition is an error condition (or a subtype of error), then
|
||
|
|
;;; HANDLER gets a chance to handle it.
|
||
|
|
;;; The HANDLER proc is applied to two values:
|
||
|
|
;;; (HANDLER condition decline)
|
||
|
|
;;; HANDLER's continuation is WITH-FATAL-ERROR-HANDLER*'s; whatever HANDLER
|
||
|
|
;;; returns is returned from WITH-FATAL-ERROR-HANDLER. HANDLER declines to
|
||
|
|
;;; handle the error by throwing to DECLINE, a nullary continuation.
|
||
|
|
;;;
|
||
|
|
;;; Why is it called with-FATAL-error-handler*? Because returning to the
|
||
|
|
;;; guy that signalled the error is not an option.
|
||
|
|
;;;
|
||
|
|
;;; Why the nested outer pair of CALL/CC's? Well, what happens if the user's
|
||
|
|
;;; error handler *itself* raises an error? This could potentially give
|
||
|
|
;;; rise to an infinite loop, because WITH-HANDLER runs its handler in
|
||
|
|
;;; the original condition-signaller's context, so you'd search back for a
|
||
|
|
;;; handler, and find yourself again. For example, here is an infinite loop:
|
||
|
|
;;;
|
||
|
|
;;; (with-handler (lambda (condition more)
|
||
|
|
;;; (display "Loop!")
|
||
|
|
;;; (error "ouch")) ; Get back, Loretta.
|
||
|
|
;;; (lambda () (error "start me up")))
|
||
|
|
;;;
|
||
|
|
;;; I could require W-F-E-H* users to code carefully, but instead I make sure
|
||
|
|
;;; the user's fatal-error handler runs in w-f-e-h*'s handler context, so
|
||
|
|
;;; if it signals a condition, we'll start the search from there. That's the
|
||
|
|
;;; point of continuation K. When the original thunk completes successfully,
|
||
|
|
;;; we dodge the K hackery by using ACCEPT to make a normal return.
|
||
|
|
|
||
|
|
(define (with-fatal-error-handler* handler thunk)
|
||
|
|
(call-with-current-continuation
|
||
|
|
(lambda (accept)
|
||
|
|
((call-with-current-continuation
|
||
|
|
(lambda (k)
|
||
|
|
(with-handler (lambda (condition more)
|
||
|
|
(if (error? condition)
|
||
|
|
(call-with-current-continuation
|
||
|
|
(lambda (decline)
|
||
|
|
(k (lambda () (handler condition decline))))))
|
||
|
|
(more)) ; Keep looking for a handler.
|
||
|
|
(lambda () (call-with-values thunk accept)))))))))
|
||
|
|
|
||
|
|
(define-syntax with-fatal-error-handler
|
||
|
|
(syntax-rules ()
|
||
|
|
((with-fatal-error-handler handler body ...)
|
||
|
|
(with-fatal-error-handler* handler
|
||
|
|
(lambda () body ...)))))
|
||
|
|
|
||
|
|
;This one ran HANDLER in the signaller's condition-handler context.
|
||
|
|
;It was therefore susceptible to infinite loops if you didn't code
|
||
|
|
;your handler's carefully.
|
||
|
|
;
|
||
|
|
;(define (with-fatal-error-handler* handler thunk)
|
||
|
|
; (call-with-current-continuation
|
||
|
|
; (lambda (accept)
|
||
|
|
; (with-handler (lambda (condition more)
|
||
|
|
; (if (error? condition)
|
||
|
|
; (call-with-current-continuation
|
||
|
|
; (lambda (decline)
|
||
|
|
; (accept (handler condition decline)))))
|
||
|
|
; (more)) ; Keep looking for a handler.
|
||
|
|
; thunk))))
|
||
|
|
|
||
|
|
;;; (%error-handler-cond kont eh-clauses cond-clauses)
|
||
|
|
;;; Transform error-handler clauses into COND clauses by wrapping continuation
|
||
|
|
;;; KONT around the body of each e-h clause, so that if it fires, the result
|
||
|
|
;;; is thrown to KONT, but if no clause fires, the cond returns to the default
|
||
|
|
;;; continuation.
|
||
|
|
|
||
|
|
;(define-syntax %error-handler-cond
|
||
|
|
; (syntax-rules (=> else)
|
||
|
|
;
|
||
|
|
; ((%error-handler-cond kont ((test => proc) clause ...) (ans ...))
|
||
|
|
; (%error-handler-cond kont
|
||
|
|
; (clause ...)
|
||
|
|
; ((test => (lambda (v) (kont (proc v)))) ans ...)))
|
||
|
|
;
|
||
|
|
; ((%error-handler-cond kont ((test body ...) clause ...) (ans ...))
|
||
|
|
; (%error-handler-cond kont
|
||
|
|
; (clause ...)
|
||
|
|
; ((test (kont (begin body ...))) ans ...)))
|
||
|
|
;
|
||
|
|
; ((%error-handler-cond kont ((else body ...)) (ans-clause ...))
|
||
|
|
; (cond (else body ...) ans-clause ...))
|
||
|
|
;
|
||
|
|
; ((%error-handler-cond kont () (ans-clause ...))
|
||
|
|
; (cond ans-clause ...))))
|