diff --git a/lib/init-7.scm b/lib/init-7.scm index b14b0540..9e87e81b 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -1160,6 +1160,41 @@ (define (raise-continuable exn) (raise (make-exception 'continuable "" exn #f #f))) +;; Support continuing certain exception types at the top level, but +;; still allow their subtypes to define themselves as serious and +;; require exiting +(define non-serious-exception-predicates '()) +(define serious-exception-predicates '()) + +(define (register-non-serious-exception-predicate! pred) + (set! non-serious-exception-predicates (cons pred non-serious-exception-predicates))) +(define (register-serious-exception-predicate! pred) + (set! serious-exception-predicates (cons pred serious-exception-predicates))) + +(define (default-exception-handler exn) + (%with-exception-handler + #f + (lambda () + (define continuable-exception? + (and (exception? exn) + (eq? 'continuable (exception-kind exn)))) + (define underlying-exn + (if continuable-exception? + (exception-irritants exn) + exn)) + (if (and continuable-exception? + (find (lambda (f) (f underlying-exn)) + non-serious-exception-predicates)) + (if (find (lambda (f) (f underlying-exn)) + serious-exception-predicates) + (raise underlying-exn) + (begin + (display "NON-SERIOUS EXCEPTION: " (current-error-port)) + (write underlying-exn (current-error-port)) + (display "\n" (current-error-port)))) + (raise underlying-exn))))) +(current-exception-handler default-exception-handler) + (cond-expand (threads (define (%with-exception-handler handler thunk) diff --git a/lib/srfi/35/internal.scm b/lib/srfi/35/internal.scm index b8b94f6f..66f7fbde 100644 --- a/lib/srfi/35/internal.scm +++ b/lib/srfi/35/internal.scm @@ -204,6 +204,9 @@ (define-condition-type/constructor &error &serious make-error error?) +(register-non-serious-exception-predicate! condition?) +(register-serious-exception-predicate! serious-condition?) + ;; (chibi repl) support (define-method (repl-print-exception (exn condition?) (out output-port?)) (define components (simple-conditions exn)) diff --git a/lib/srfi/35/internal.sld b/lib/srfi/35/internal.sld index 0bc944a6..8dfbd330 100644 --- a/lib/srfi/35/internal.sld +++ b/lib/srfi/35/internal.sld @@ -6,7 +6,9 @@ (scheme write) (only (chibi) slot-ref - is-a?) + is-a? + register-non-serious-exception-predicate! + register-serious-exception-predicate!) (only (chibi repl) repl-print-exception) (only (chibi generic) define-method) ;; don’t let people go messing with a compound condition