diff --git a/s48/exceptions/restart.scm b/s48/exceptions/restart.scm new file mode 100644 index 0000000..e3d83b4 --- /dev/null +++ b/s48/exceptions/restart.scm @@ -0,0 +1,49 @@ +;;; extremly simple restartable conditions with SRFI-34/35 + +;;; This file is part of the Scheme Untergrund Library. + +;;; Copyright (c) 2004 by Eric Knauel. +;;; For copyright information, see the file COPYING which comes with +;;; the distribution. + +;;; Example: + +;;; (define-condition-type &harmless &condition +;;; harmless-condition?) +;;; +;;; (with-exception-handler +;;; (lambda (c) +;;; (cond +;;; ((harmless-condition? c) +;;; (display "Oops!") +;;; (newline) +;;; (restart c)) +;;; (else +;;; (error (condition-message c))))) +;;; (lambda () +;;; (display "Everything ok.") +;;; (newline) +;;; (raise-restartable (condition (&harmless))) +;;; (display "Never mind.") +;;; (newline) +;;; (raise-restartable (condition (&message (message "Ouch!")))))) + +(define-condition-type &restartable-condition &condition + restartable-condition? + (cont restartable-condition-cont)) + +(define-syntax raise-restartable + (syntax-rules () + ((raise-restartable %obj) + (call-with-current-continuation + (lambda (restart-cont) + (raise + (make-compound-condition + (condition (&restartable-condition (cont restart-cont))) %obj))))))) + +(define-syntax restart + (syntax-rules () + ((restart %condition) + (if (restartable-condition? %condition) + ((condition-ref (extract-condition %condition &restartable-condition) 'cont) 'ignored) + (raise (condition (&message (message "not a restartable condition"))))))))