(import (vicare)
  (only (vicare checks)
        with-result
        add-result))

;;; use-value

;;Signal condition, call a handler, call a USE-VALUE restart.
;;
(with-result
  (handler-bind
      ((&error (lambda (E)
                 (add-result 'error-handler-begin)
                 (use-value "ciao")
                 (add-result 'error-handler-return))))
    (restart-case
        (begin
          (add-result 'body-begin)
          (signal (make-error))
          (add-result 'body-return))
      (use-value (lambda (value)
                   (add-result 'restart-use-value)
                   value)))))
⇒ ("ciao"
      (body-begin error-handler-begin restart-use-value))

;;Call a USE-VALUE restart, no USE-VALUE handler is defined.
;;
(with-result
  (add-result 'body-begin)
  (begin0
      (use-value 1)
    (add-result 'body-return)))
⇒ (#f (body-begin body-return))

;;; store-value

;;Signal condition, call a handler, call a STORE-VALUE restart.
;;
(with-result
  (handler-bind
      ((&error (lambda (E)
                 (add-result 'error-handler-begin)
                 (store-value "ciao")
                 (add-result 'error-handler-return))))
    (restart-case
        (begin
          (add-result 'body-begin)
          (signal (make-error))
          (add-result 'body-return))
      (store-value (lambda (value)
                     (add-result 'restart-store-value)
                     value)))))
⇒ ("ciao"
      (body-begin error-handler-begin restart-store-value))

;;Call a STORE-VALUE restart, no STORE-VALUE handler is defined.
;;
(with-result
  (add-result 'body-begin)
  (begin0
      (store-value 1)
    (add-result 'body-return)))
⇒ (#f (body-begin body-return))

;;; store-value/use-value

;;Adapted example from Common Lisp's Hyper Spec.
;;
(internal-body

  (define-condition-type &unbound-symbol-error
      &error
    make-unbound-symbol-error
    unbound-symbol-error?)

  (define* (careful-symbol-value sym)
    (restart-case
        (if (symbol-bound? sym)
            (symbol-value sym)
          (signal (make-unbound-symbol-error)))
      (use-value   (lambda (obj) obj))
      (store-value (lambda (obj)
                     (set-symbol-value! sym obj)
                     obj))))

  (let ((sym (gensym)))
    (set-symbol-value! sym 1)
    (careful-symbol-value sym))
  ⇒ 1

  (let ((sym (gensym)))
    (handler-bind
        ((&unbound-symbol-error (lambda (E)
                                  (use-value 1))))
      (careful-symbol-value sym)))
  ⇒ 1

  (let ((sym (gensym)))
    (handler-bind
        ((&unbound-symbol-error (lambda (E)
                                  (store-value 1))))
      (values (careful-symbol-value sym)
              (careful-symbol-value sym))))
  ⇒ 1 1

  #| end of INTERNAL-BODY |# )

;;; continue

;;Signal condition, call a handler, call a CONTINUE restart.
;;
(with-result
  (handler-bind
      ((&error (lambda (E)
                 (add-result 'error-handler-begin)
                 (continue-restart)
                 (add-result 'error-handler-return))))
    (restart-case
        (begin
          (add-result 'body-begin)
          (signal (make-error))
          (add-result 'body-return))
      (continue (lambda ()
                  (add-result 'restart-continue)
                  2)))))
⇒ (2 (body-begin error-handler-begin restart-continue))

;;CONTINUE example derived from Common Lisp's Hyper Spec.
;;
(internal-body

  (define (real-sqrt n)
    (when (negative? n)
      (set! n (- n))
      (restart-case
          (signal (make-error))
        (continue (lambda ()
                    (add-result 'continue-restart)))))
    (sqrt n))

  (with-result
    (handler-bind
        ((&error (lambda (E)
                   (add-result 'error-handler)
                   (continue-restart))))
      (add-result 'body-enter)
      (begin0
          (real-sqrt -9)
        (add-result 'body-return)))))
⇒ (3
      (body-enter error-handler continue-restart body-return))

;;Call a CONTINUE restart, no CONTINUE handler is defined.
;;
(with-result
    (try
        (restart-case
            (begin
              (add-result 'body-begin)
              (begin0
                  (continue-restart)
                (add-result 'body-return))))
      (catch E
        ((&restarts-control-error)
         (add-result 'catch-control-error)
         2)
        (else
         (print-condition E)
         3))))
⇒ (#f (body-begin body-return))

;;Signal condition, call  the inner handler, call an CONTINUE  restart, no CONTINUE
;;handler is defined, call the outer handler, return.
;;
(with-result
  (with-return-to-signal-on-unhandled-exception
    (handler-bind
        ((&error (lambda (E)
                     (add-result 'outer-error-handler))))
        (handler-bind
            ((&error (lambda (E)
                       (add-result 'inner-error-handler-begin)
                       (continue-restart)
                       (add-result 'inner-error-handler-return))))
          (add-result 'body-begin)
          (signal (make-error))
          (add-result 'body-return)
          1))))
⇒ (1
      (body-begin
       inner-error-handler-begin
       inner-error-handler-return
       outer-error-handler
       body-return))

;;; abort

;;Signal condition, call a handler, call an ABORT restart.
;;
(with-result
  (handler-bind
      ((&error (lambda (E)
                 (add-result 'error-handler-begin)
                 (abort-restart)
                 (add-result 'error-handler-return))))
    (restart-case
        (begin
          (add-result 'body-begin)
          (signal (make-error))
          (add-result 'body-return))
      (abort (lambda ()
               (add-result 'restart-abort)
               2)))))
⇒ (2 (body-begin error-handler-begin restart-abort))

;;Call an ABORT restart, no ABORT handler is defined.
;;
(with-result
  (try
      (begin
        (add-result 'body-begin)
        (abort-restart)
        (add-result 'body-return))
    (catch E
      ((&restarts-control-error)
       (add-result 'catch-control-error)
       2)
      (else E))))
⇒ (2 (body-begin catch-control-error))

;;Signal condition, call a handler, call an ABORT restart,
;;no ABORT handler is defined.
;;
(with-result
  (try
      (handler-bind
          ((&error (lambda (E)
                     (add-result 'error-handler-begin)
                     (abort-restart)
                     (add-result 'error-handler-return))))
        (add-result 'body-begin)
        (signal (make-error))
        (add-result 'body-return))
    (catch E
      ((&restarts-control-error)
       (add-result 'catch-control-error)
       2)
      (else E))))
⇒ (2 (body-begin error-handler-begin catch-control-error))