;; lecture14-exceptions.ss
;;
;; Exceptions using call/cc and dynamic-wind
;;
;; We'll represent exceptions as a list whose first element is a
;; symbol representing the exception name; e.g.
;;
;; '(empty "List is empty!")
;;

;; We'll maintain a global stack of handlers.
;; A handler should be represented as a 3-element list
;;
;;    (exnName cont handlerFn)
;;
;;   exnName   is a symbol naming the exception to be handled,
;;   cont      is the continuation for the expression whose evaluation
;;             we are attempting, and
;;   handlerFn is a single-argument function that takes the
;;             exception value and returns the value to return
;;             as the value of the entire catch expression
;;
(define handler-stack ())
(define (push-handler handler)
  (set! handler-stack (cons handler handler-stack)))
(define (pop-handler)
  (if (not (null? handler-stack))
      (let ((top (car handler-stack)))
        (set! handler-stack (cdr handler-stack))
        top)))

;; When there's an uncaught exception, we need a way to terminate
;; evaluation all-the-way to top-level.  This is the way.
(define exit-to-toplevel 'dummy)
(call/cc (lambda (cont) (set! exit-to-toplevel cont)))

;; handle will take an exception name, a no-argument body function,
;; and a function to invoke on the exception value if the
;; named exception is thrown:
(define (handle exnName bodyFn handlerFn)
  (call/cc (lambda (cont)
             (dynamic-wind
              (lambda () (push-handler (list exnName cont handlerFn)))
              bodyFn
              (lambda () (pop-handler))))))

;; raise will take an exception value, and crawl up the stack
;; of handlers until it finds one that can handle the current
;; exception.  When it finds such a handler, it will pass it
;; the exception value and return that value to the continuation
;; saved at the handle site.
(define (raise anExn)
  (if (null? handler-stack)
      (begin
        (map display '("uncaught exception: " anExn))
        (exit-to-toplevel))
      ;; else
      (let* ((exn-name (car anExn))
             (handler (pop-handler))
             (handler-exn-name (car handler)))
        (if (eq? exn-name handler-exn-name)
            (let ((handler-cont (cadr handler))
                  (handler-fn   (caddr handler)))
              (handler-cont (handler-fn anExn)))
            ;; else
            (raise anExn)))))

;;
;; Usages of handle/raise
;;

(define (find-or-raise pred x)
  (cond ((null? x) (raise '(empty "No such element in list.")))
        ((pred (car x)) (car x))
        (else (find-or-raise pred (cdr x)))))

(define gt0 (lambda (x) (> x 0)))

;; ordinary termination
(find-or-raise gt0 '(-1 -2 3 4))

;; failure termination
(find-or-raise gt0 '(-1 -2 -3 -4))

;; handle termination
(handle 'empty
        (lambda () (find-or-raise gt0 '(-1 -2 -3 -4)))
        (lambda (anExn) -1))