;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
;; ALL RIGHTS RESERVED.
;;
;; $Id: must-condition.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 
;;  * Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;  * Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in
;;    the documentation and/or other materials provided with the
;;    distribution.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;; signal
(eq (signal "test signal") nil)
(eq (signal 'simple-error :format-control "simple-error" :format-arguments nil)
    nil)
(eq (signal 'simple-warning
            :format-control "simple-warning" :format-arguments nil)
    nil)
(handler-case (signal "test simple-condition")
  (simple-condition () t)
  (condition () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(handler-case (signal 'simple-warning :format-control "simple warning"
                      :format-arguments nil)
  (simple-warning () t)
  (warning () nil)
  (condition () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(handler-case (signal 'type-error :datum nil :expected-type 'vector)
  (type-error () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(let ((*break-on-signals* 'arithmetic-error))
  (handler-case (signal 'type-error :datum nil :expected-type 'vector)
    (type-error () t)
    (error () nil)
    (:no-error (&rest rest) (declare (ignore rest)) nil)))


;; error
(handler-case (error "simple-error test")
  (simple-error () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(handler-case (error 'type-error :datum nil :expected-type 'vector)
  (type-error () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(handler-case (error 'no-such-error!!)
  (type-error () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(handler-case (error 'simple-condition :format-control "simple-condition test")
  (simple-condition () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(handler-case (error 'simple-warning :format-control "simple-warning test")
  (simple-warning () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))



;; cerror
(handler-case (cerror "Continue." "error test")
  (simple-error () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(handler-case (cerror "Continue." 'type-error :datum nil :expected-type 'vector)
  (type-error () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(handler-bind ((simple-error #'(lambda (condition)
                                 (declare (ignore condition))
                                 (invoke-restart 'continue))))
  (eq (cerror "Continue." "error test") nil))
(handler-bind ((type-error #'(lambda (condition)
                               (declare (ignore condition))
                               (invoke-restart 'continue))))
  (eq (cerror "Continue." 'type-error :datum nil :expected-type 'vector) nil))



;; warn
(let ((*error-output* (make-string-output-stream)))
  (and (eq (warn "I warn you!") nil)
       (get-output-stream-string *error-output*)))
(handler-bind ((warning #'(lambda (condition)
                            (declare (ignore condition))
                            (invoke-restart 'muffle-warning))))
  (eq (warn "I warn you!") nil))
(let ((*error-output* (make-string-output-stream)))
  (handler-bind ((warning #'(lambda (condition)
                              (declare (ignore condition))
                              (invoke-restart 'muffle-warning))))
    (and (eq (warn "I warn you!") nil)
         (string= (get-output-stream-string *error-output*) ""))))
(block tag
  (handler-case (warn 'simple-error
                      :format-control "boom!" :format-arguments nil)
    (type-error () t)
    (simple-error () nil)
    (error () nil)
    (:no-error (&rest rest) (declare (ignore rest)) nil)))
(block tag
  (handler-case (warn 'simple-condition
                      :format-control "boom!" :format-arguments nil)
    (type-error () t)
    (simple-condition () nil)
    (error () nil)
    (:no-error (&rest rest) (declare (ignore rest)) nil)))
(block tag
  (let ((condition (make-condition 'simple-condition
                                   :format-control "boom!"
                                   :format-arguments nil)))
    (handler-case (warn condition)
      (type-error () t)
      (simple-condition () nil)
      (error () nil)
      (:no-error (&rest rest) (declare (ignore rest)) nil))))
(block tag
  (let ((condition (make-condition 'simple-error
                                   :format-control "boom!"
                                   :format-arguments nil)))
    (handler-case (warn condition)
      (type-error () t)
      (simple-error () nil)
      (error () nil)
      (:no-error (&rest rest) (declare (ignore rest)) nil))))
(block tag
  (let ((condition (make-condition 'simple-warning
                                   :format-control "boom!"
                                   :format-arguments nil)))
    (handler-case (warn condition)
      (type-error () nil)
      (simple-warning () t)
      (error () nil)
      (:no-error (&rest rest) (declare (ignore rest)) nil))))
(block tag
  (let ((condition (make-condition 'simple-warning
                                   :format-control "boom!"
                                   :format-arguments nil)))
    (handler-case (warn condition :format-control "boom!" :format-arguments nil)
      (type-error () t)
      (simple-warning () nil)
      (error () nil)
      (:no-error (&rest rest) (declare (ignore rest)) nil))))



;; handler-bind
(null (handler-bind ()))
(handler-bind () t)
(equal (multiple-value-list (handler-bind () 1 2 3 (values 4 5 6))) '(4 5 6))
(eq 'handled
    (block tag (handler-bind ((type-error #'(lambda (c)
                                              (declare (ignore c))
                                              (return-from tag 'handled))))
                 (error 'type-error :datum nil :expected-type 'vector))))
(eq 'handled
    (block tag (handler-bind ((error #'(lambda (c)
                                         (declare (ignore c))
                                         (return-from tag 'handled))))
                 (error 'type-error :datum nil :expected-type 'vector))))
(eq 'handled
    (block tag (handler-bind ((condition #'(lambda (c)
                                         (declare (ignore c))
                                         (return-from tag 'handled))))
                 (error 'type-error :datum nil :expected-type 'vector))))
(eq 'outer-handler
    (block tag
      (handler-bind ((type-error #'(lambda (c)
                                     (declare (ignore c))
                                     (return-from tag 'outer-handler))))
        (handler-bind ((type-error #'(lambda (c) (error c)))
                       (type-error #'(lambda (c)
                                       (declare (ignore c))
                                       (return-from tag 'inner-handler))))
          (error 'type-error :datum nil :expected-type 'vector)))))
(eq 'outer-handler
    (block tag
      (handler-bind ((error #'(lambda (c)
                                (declare (ignore c))
                                (return-from tag 'outer-handler))))
        (handler-bind ((type-error #'(lambda (c) (error c)))
                       (type-error #'(lambda (c)
                                       (declare (ignore c))
                                       (return-from tag 'inner-handler))))
          (error 'type-error :datum nil :expected-type 'vector)))))
(eq 'left-handler
    (block tag
      (handler-bind ((type-error #'(lambda (c)
                                     (declare (ignore c))
                                     (return-from tag 'left-handler)))
                     (type-error #'(lambda (c)
                                     (declare (ignore c))
                                     (return-from tag 'right-handler))))
        (error 'type-error :datum nil :expected-type 'vector))))
(eq 'left-handler
    (block tag
      (handler-bind ((error #'(lambda (c)
                                (declare (ignore c))
                                (return-from tag 'left-handler)))
                     (type-error #'(lambda (c)
                                     (declare (ignore c))
                                     (return-from tag 'right-handler))))
        (error 'type-error :datum nil :expected-type 'vector))))
(eq 'left-handler
    (block tag
      (handler-bind ((type-error #'(lambda (c)
                                     (declare (ignore c))
                                     (return-from tag 'left-handler)))
                     (error #'(lambda (c)
                                (declare (ignore c))
                                (return-from tag 'right-handler))))
        (error 'type-error :datum nil :expected-type 'vector))))
(let ((handler-declined nil))
  (and (eq (handler-bind ((type-error #'(lambda (c)
                                          (declare (ignore c))
                                          (setq handler-declined t))))
             (signal 'type-error :datum nil :expected-type 'vector))
           nil)
       handler-declined))
(let ((handler-declined nil))
  (and (eq (handler-bind ((type-error #'(lambda (c)
                                          (declare (ignore c))
                                          (push 'outer handler-declined))))
             (handler-bind ((type-error #'(lambda (c)
                                            (declare (ignore c))
                                            (push 'inner handler-declined))))
               (signal 'type-error :datum nil :expected-type 'vector)))
           nil)
       (equal handler-declined '(outer inner))))
(let ((handler-declined nil))
  (and (eq (handler-bind
               ((type-error #'(lambda (c)
                                (declare (ignore c))
                                (push 'outer-left-handler handler-declined)))
                (type-error #'(lambda (c)
                                (declare (ignore c))
                                (push 'outer-right-handler handler-declined))))
             (handler-bind
                 ((type-error #'(lambda (c)
                                  (declare (ignore c))
                                  (push 'inner-left-handler handler-declined)))
                  (type-error #'(lambda (c)
                                  (declare (ignore c))
                                  (push 'inner-right-handler handler-declined))))
               (signal 'type-error :datum nil :expected-type 'vector)))
           nil)
       (equal handler-declined '(outer-right-handler outer-left-handler
                                 inner-right-handler inner-left-handler))))
(let ((handler-declined nil))
  (and (eq (handler-bind
               ((type-error #'(lambda (c)
                                (declare (ignore c))
                                (push 'outer-left-handler handler-declined)))
                (type-error #'(lambda (c)
                                (declare (ignore c))
                                (push 'outer-right-handler handler-declined))))
             (handler-bind
                 ((type-error #'(lambda (c)
                                  (declare (ignore c))
                                  (push 'inner-left-handler handler-declined)))
                  (type-error #'(lambda (c)
                                  (signal c)
                                  (push 'inner-right-handler handler-declined))))
               (signal 'type-error :datum nil :expected-type 'vector)))
           nil)
       (equal handler-declined '(outer-right-handler
                                 outer-left-handler
                                 inner-right-handler

                                 outer-right-handler
                                 outer-left-handler

                                 inner-left-handler))))
(let ((*dynamic-var* nil))
  (declare (special *dynamic-var*))
  (block tag
    (handler-bind ((type-error #'(lambda (c)
                                   (declare (ignore c))
                                   (return-from tag *dynamic-var*))))
      (let ((*dynamic-var* t))
        (declare (special *dynamic-var*))
        (signal 'type-error :datum nil :expected-type 'vector)))))
(let ((declined nil))
  (and (eq nil
           (handler-bind ((simple-condition #'(lambda (c)
                                                (declare (ignore c))
                                                (push 'specific declined))))
             (handler-bind ((condition #'(lambda (c)
                                           (declare (ignore c))
                                           (push 'general declined))))
               (signal "error"))))
       (equal declined '(specific general))))
(block tag
  (handler-bind ((error #'(lambda (c) (return-from tag (typep c 'error)))))
    (error "error")))
(eq 'ok
    (block tag
      (handler-bind ((error #'(lambda (c)
                                (declare (ignore c))
                                (return-from tag 'ok))))
        (handler-bind ((error #'(lambda (c)
                                  (declare (ignore c))
                                  (error "error3"))))
          (handler-bind ((error #'(lambda (c)
                                    (declare (ignore c))
                                    (error "error2"))))
            (error "error"))))))
(eq 'ok
    (block tag
      (handler-bind
          ((error
            #'(lambda (c)
                (declare (ignore c))
                (handler-bind
                    ((error #'(lambda (c)
                                (declare (ignore c))
                                (handler-bind
                                    ((error #'(lambda (c)
                                                (declare (ignore c))
                                                (return-from tag 'ok))))
                                  (error "error2")))))
                  (error "error1")))))
        (error "error0"))))


;; handler-case
(handler-case t)
(handler-case nil
  (:no-error (&rest rest) (declare (ignore rest)) t))
(equal (multiple-value-list (handler-case (values 0 1 2 3 4)))
       '(0 1 2 3 4))
(equal (handler-case (values 0 1 2 3 4)
         (:no-error (&rest rest) rest))
       '(0 1 2 3 4))
(equal (multiple-value-list (handler-case (values 0 1 2 3 4)
                              (:no-error (&rest rest) (values rest 5 6 7 8))))
       '((0 1 2 3 4) 5 6 7 8))
(eq t (handler-case t
        (type-error () 'type-error)
        (error () 'error)))
(eq 'simple-error
    (handler-case (error "error!")
      (simple-error () 'simple-error)
      (error () 'error)))
(eq 'error
    (handler-case (error "error!")
      (error () 'error)
      (simple-error () 'simple-error)))
(eq 'error
    (handler-case (error "error!")
      (error () 'error)
      (condition () 'condition)
      (simple-error () 'simple-error)))
(eq 'condition
    (handler-case (error "error!")
      (condition () 'condition)
      (error () 'error)
      (simple-error () 'simple-error)))
(eq 'simple-error
    (handler-case (signal 'simple-error
                          :format-control "error!" :format-arguments nil)
      (simple-error () 'simple-error)
      (error () 'error)))
(eq 'simple-error-left
    (handler-case (signal 'simple-error
                          :format-control "error!" :format-arguments nil)
      (simple-error () 'simple-error-left)
      (simple-error () 'simple-error-right)))
(eq 'no-one-handled
    (handler-case (progn
                    (signal 'simple-warning
                            :format-control "warning!" :format-arguments nil)
                    'no-one-handled)
      (simple-error () 'simple-error)
      (error () 'error)))
(equal (handler-case (progn
                       (signal 'simple-warning
                               :format-control "warning!" :format-arguments nil)
                       'no-one-handled)
         (:no-error (&rest rest) (cons 'no-error rest))
         (simple-error () 'simple-error)
         (error () 'error))
       '(no-error no-one-handled))
(let ((where 'out))
  (eq (handler-case (let ((where 'in))
                      (declare (ignorable where))
                      (error "error!"))
        (error () where))
      'out))
(let ((where 'out))
  (declare (special where))
  (eq (handler-case (let ((where 'in))
                      (declare (special where))
                      (error "~S" where))
        (error () where))
      'out))
(typep (handler-case (error "error!")
         (error (c) c))
       'simple-error)
(typep (handler-case (error "error!")
         (condition (c) c))
       'simple-error)
(typep (handler-case (signal "condition")
         (condition (c) c))
       'simple-condition)
(typep (handler-case (warn "warning")
         (condition (c) c))
       'simple-warning)



;; restart-bind
(null (restart-bind ()))
(restart-bind () t)
(= (restart-bind () 0 1 2) 2)
(equal (multiple-value-list (restart-bind () 0 1 2 (values 3 4 5))) '(3 4 5))
(block tag
  (restart-bind ((continue #'(lambda (&rest rest)
                               (declare (ignore rest))
                               (return-from tag t))))
    (handler-case (signal "testing simple-signal")
      (simple-condition () (invoke-restart 'continue)))))
(block tag
  (handler-bind ((simple-condition #'(lambda (condition)
                                       (declare (ignore condition))
                                       (invoke-restart 'continue))))
    (restart-bind ((continue #'(lambda (&rest rest)
                                 (declare (ignore rest))
                                 (return-from tag t))))
      (signal "testing simple-condition"))))
(block tag
  (restart-bind ((continue  #'(lambda (&rest rest)
                                 (declare (ignore rest))
                                 (return-from tag nil))))
    (handler-bind ((simple-condition #'(lambda (condition)
                                         (declare (ignore condition))
                                         (invoke-restart 'continue))))
      (restart-bind ((continue #'(lambda (&rest rest)
                                   (declare (ignore rest))
                                   (return-from tag t))))
        (signal "testing simple-condition")))))
(block tag
  (restart-bind ((continue #'(lambda (&rest rest)
                               (declare (ignore rest))
                               (return-from tag t)))
                 (continue #'(lambda (&rest rest)
                               (declare (ignore rest))
                               (return-from tag nil))))
    (handler-case (signal "testing simple-signal")
      (simple-condition () (invoke-restart 'continue)))))
(block tag
  (restart-bind ((continue #'(lambda (&rest rest)
                               (declare (ignore rest))
                               (return-from tag t))
                   :report-function #'(lambda (stream)
                                        (format stream "Continue"))))
    (handler-case (signal "testing simple-signal")
      (simple-condition () (invoke-restart 'continue)))))
(block tag
  (restart-bind ((continue #'(lambda (x) (return-from tag x))
                   :report-function
                   #'(lambda (stream) (format stream "Continue"))
                   :interactive-function #'(lambda () (list t))))
    (handler-case (signal "testing simple-signal")
      (simple-condition () (invoke-restart-interactively 'continue)))))
(eq 'ok
    (block tag
      (restart-bind ((continue #'(lambda (x) (return-from tag x))))
        (handler-case (signal "testing simple-signal")
          (simple-condition () (invoke-restart 'continue 'ok))))))
(block tag
  (restart-bind ((continue #'(lambda (x) (return-from tag x))
                   :report-function
                   #'(lambda (stream) (format stream "Continue"))
                   :interactive-function #'(lambda () (list t))
                   :test-function (constantly t)))
    (handler-case (signal "testing simple-signal")
      (simple-condition () (invoke-restart-interactively 'continue)))))
(block tag
  (restart-bind ((continue #'(lambda (x) (return-from tag x))
                   :report-function
                   #'(lambda (stream) (format stream "Continue"))
                   :interactive-function #'(lambda () (list t))
                   :test-function
                   #'(lambda (c) (or (null c) (typep c 'simple-condition)))))
    (handler-case (signal "testing simple-signal")
      (simple-condition () (invoke-restart-interactively 'continue)))))
(block tag
  (restart-bind ((tb-continue #'(lambda (x) (return-from tag x))
                   :interactive-function #'(lambda () (list t))
                   :test-function (constantly nil)
                   :report-function
                   #'(lambda (stream) (format stream "Continue"))))
    (not (find-restart 'tb-continue))))
(block tag
  (restart-bind ((tb-continue #'(lambda (x) (return-from tag x))
                   :interactive-function #'(lambda () (list t))
                   :test-function (constantly t)
                   :report-function #'(lambda (stream) (format stream "cont."))))
    (handler-case (signal "testing simple-signal")
      (simple-condition () (invoke-restart-interactively 'tb-continue)))))
(null (let ((*dynamic-var* nil))
        (declare (special *dynamic-var*))
        (block tag
          (restart-bind ((continue #'(lambda (x)
                                       (declare (ignore x))
                                       (return-from tag *dynamic-var*))
                           :interactive-function #'(lambda () (list t))
                           :test-function (constantly t)
                           :report-function
                           #'(lambda (stream) (format stream "cont."))))
            (handler-case (let ((*dynamic-var* t))
                            (declare (special *dynamic-var*))
                            (signal "testing simple-signal"))
              (simple-condition () (invoke-restart-interactively 'continue)))))))
(let ((*dynamic-var* nil))
        (declare (special *dynamic-var*))
        (block tag
          (restart-bind ((continue #'(lambda (x)
                                       (declare (ignore x))
                                       (return-from tag *dynamic-var*))
                           :interactive-function #'(lambda () (list t))
                           :test-function (constantly t)
                           :report-function
                           #'(lambda (stream) (format stream "cont."))))
            (handler-bind ((simple-condition
                            #'(lambda (c)
                                (declare (ignore c))
                                (invoke-restart-interactively 'continue))))
              (let ((*dynamic-var* t))
                (declare (special *dynamic-var*))
                (signal "testing simple-signal"))))))
(block tag
  (restart-bind ((nil #'(lambda (&rest rest)
                               (declare (ignore rest))
                               (return-from tag t))))
    (handler-case (signal "testing simple-signal")
      (simple-condition () (invoke-restart 'nil)))))



;; restart-case
(restart-case t)
(restart-case t
  (continue (&rest rest) (declare (ignore rest)) nil))
(equal (multiple-value-list (restart-case (values 0 1 2 3 4))) '(0 1 2 3 4))
(eq 'continued
    (restart-case (continue)
      (continue (&rest rest) (declare (ignore rest)) 'continued)))
(eq nil
    (restart-case (continue)
      (continue (&rest rest) (declare (ignore rest)))))
(eq 'continue-left
    (restart-case (continue)
      (continue (&rest rest) (declare (ignore rest)) 'continue-left)
      (continue (&rest rest) (declare (ignore rest)) 'continue-right)))
(null (restart-case (invoke-restart 'continue)
        (continue (&rest rest)
          :interactive (lambda () (list 0 1 2 3))
          rest)))
(equal (restart-case (invoke-restart-interactively 'continue)
         (continue (&rest rest)
           :interactive (lambda () (list 0 1 2 3))
           rest))
       '(0 1 2 3))
(equal (restart-case (invoke-restart-interactively 'continue)
         (continue (&rest rest)
           :interactive (lambda () (list 0 1 2 3))
           :report "continue"
           rest))
       '(0 1 2 3))
(equal (restart-case (invoke-restart-interactively 'continue)
         (continue (&rest rest)
           :interactive (lambda () (list 0 1 2 3))
           :report "continue"
           :test  (lambda (c) (declare (ignore c)) t)
           rest))
       '(0 1 2 3))
(= (restart-case
       (handler-bind ((error #'(lambda (c)
                                 (declare (ignore c))
                                 (invoke-restart 'my-restart 7))))
         (error "Foo."))
     (my-restart (&optional v) v))
   7)
(eq (handler-bind ((error #'(lambda (c)
                              (declare (ignore c))
                              (invoke-restart 'my-restart 'restarted))))
      (restart-case (error "Boo.")
        (my-restart (&optional v) v)))
    'restarted)
(eq (handler-bind ((error #'(lambda (c)
                              (invoke-restart (find-restart 'my-restart c)
                                              'restarted))))
      (restart-case (error "Boo.")
        (my-restart (&optional v) v)))
    'restarted)

(> (length
    (block tag
      (handler-bind ((error #'(lambda (c)
                                (return-from tag (compute-restarts c)))))
        (restart-case (error "Boo.")
          (my-restart (&optional v) v)
          (my-restart (&optional v) v)))))
    1)
(eq 'ok
    (restart-case (invoke-restart 'nil)
      (nil (&rest rest) (declare (ignore rest)) 'ok)))






;; compute-restarts
(listp (mapcar #'restart-name (compute-restarts)))
(listp (mapcar #'restart-name
               (compute-restarts (make-condition 'simple-error
                                                 :format-control "error"
                                                 :format-arguments nil))))
(restart-case (let ((list (compute-restarts)))
                (and (member 'my-restart list
                             :test #'string= :key #'restart-name)
                     (member 'your-restart list
                             :test #'string= :key #'restart-name)))
  (my-restart ())
  (your-restart ()))
(restart-case (let ((list (compute-restarts)))
                (member 'my-restart
                        (cdr (member 'my-restart list
                                     :test #'string= :key #'restart-name))
                        :test #'string= :key #'restart-name))
  (my-restart ())
  (my-restart ()))


;; find-restart
(or (find-restart 'continue) t)
(restart-case (find-restart 'my-restart)
  (my-restart ()))
(restart-case (find-restart (find-restart 'my-restart))
  (my-restart ()))
(let ((condition (make-condition 'simple-error
                                 :format-control "error" :format-arguments nil)))
  (block tag
    (handler-bind ((error
                    #'(lambda (c)
                        (return-from tag (and (eq c condition)
                                              (find-restart 'my-restart c))))))
      (restart-case (error condition)
        (my-restart ())))))


;; restart-name
(string= "MY-RESTART"
         (block tag
           (handler-bind
               ((error
                 #'(lambda (c)
                     (return-from tag (restart-name
                                       (find-restart 'my-restart c))))))
             (restart-case (error "error!")
               (my-restart ())))))
(null (block tag
        (handler-bind
            ((error
              #'(lambda (c)
                  (return-from tag (restart-name
                                    (find-restart 'nil c))))))
          (restart-case (error "error!")
            (nil ())))))


;; with-condition-restarts
(null (with-condition-restarts
          (make-condition 'simple-error
                          :format-control "error" :format-arguments nil)
        ()))
(with-condition-restarts
    (make-condition 'simple-error
                    :format-control "error" :format-arguments nil)
  () t)
(equal
 (multiple-value-list
  (with-condition-restarts
      (make-condition 'simple-error
                      :format-control "error" :format-arguments nil)
    () 0 1 2 (values 3 4 5)))
 '(3 4 5))
(let ((condition (make-condition 'simple-error
                                 :format-control "error" :format-arguments nil))
      (other (make-condition 'simple-error
                             :format-control "error" :format-arguments nil)))
  (block tag
    (handler-bind
        ((error
          #'(lambda (c)
              (return-from tag (and (find-restart 'my-restart c)
                                    (null (with-condition-restarts other
                                            (compute-restarts)
                                            (find-restart 'my-restart c))))))))
      (restart-case (progn 3 2 1 'go (error condition))
        (my-restart ())))))


;; with-simple-restart
(null (with-simple-restart (continue "continue")))
(with-simple-restart (continue "continue") t)
(equal (multiple-value-list
        (with-simple-restart (continue "continue") 0 1 (values 2 3 4)))
       '(2 3 4))
(equal (multiple-value-list
        (with-simple-restart (continue "continue")
          (continue)))
       '(nil t))
(equal (multiple-value-list
        (with-simple-restart (continue "continue")
          (handler-case (error "boo")
            (error (c) (declare (ignore c)) (invoke-restart 'continue)))))
       '(nil t))


;; abort
(eq 'ok
    (restart-case (abort)
      (abort () 'ok)))
(let ((condition (make-condition 'simple-error
                                 :format-control "error" :format-arguments nil)))
  (or (find-restart 'abort condition)
      (eq 'handled
          (handler-case (abort condition)
            (control-error () 'handled)
            (condition () nil)))))

;; muffle-warning
(eq 'ok
    (restart-case (muffle-warning)
      (muffle-warning () 'ok)))
(let ((condition (make-condition 'simple-warning
                                 :format-control "warning"
                                 :format-arguments nil)))
  (or (find-restart 'muffle-warning condition)
      (eq 'handled
          (handler-case (muffle-warning condition)
            (control-error () 'handled)
            (condition () nil)))))

;; continue
(eq 'ok
    (restart-case (continue)
      (continue () 'ok)))
(let ((condition (make-condition 'simple-error
                                 :format-control "error"
                                 :format-arguments nil)))
  (or (find-restart 'continue condition)
      (null (continue condition))))

;; store-value
(eq 'ok
    (restart-case (store-value 'ok)
      (store-value (value) value)))
(let ((condition (make-condition 'simple-error
                                 :format-control "error"
                                 :format-arguments nil)))
  (or (find-restart 'store-value condition)
      (null (store-value t condition))))

;; use-value
(eq 'ok
    (restart-case (use-value 'ok)
      (use-value (value) value)))
(let ((condition (make-condition 'simple-error
                                 :format-control "error"
                                 :format-arguments nil)))
  (or (find-restart 'use-value condition)
      (null (use-value t condition))))





;; assert
(eq (assert t) nil)
(handler-case (assert nil)
  (error () t)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(let ((count 0))
  (and (eq (assert (incf count)) nil)
       (= count 1)))
(handler-case (let ((var nil)) (assert var (var) "VAR should be true."))
  (simple-error () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(let ((str (copy-seq "ABC"))
      (count 0))
  (and (eq (assert (char= (aref str 0) #\A) ((aref (progn (incf count) str) 0)))
           nil)
       (zerop count)))
(let ((str (copy-seq "ABC"))
      (count 0))
  (and (eq (assert (and (char= (aref str 0) #\A)
                        (char= (aref str 1) #\B))
                   ((aref (progn (incf count) str) 0)
                    (aref (progn (incf count) str) 1)))
           nil)
       (zerop count)))
(handler-case (let ((var nil))
                (assert var (var) 'type-error :expected-type 'array))
  (type-error () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))


;; check-type
(null (let ((var nil)) (check-type var null)))
(null (let ((var '(a b c))) (check-type var cons)))
(handler-case (let ((var '(a b c))) (check-type var vector))
  (type-error () t)
  (error () nil)
  (:no-error (&rest rest) (declare (ignore rest)) nil))
(eq 'handled
    (block tag 
      (handler-bind ((type-error
                      #'(lambda (c)
                          (declare (ignore c))
                          (return-from tag 'handled)))
                     (error #'(lambda (c)
                                (declare (ignore c))
                                (return-from tag nil))))
        (let ((var '(a b c)))
          (check-type var vector)
          var))))
(string= (block tag 
           (handler-bind ((type-error
                           #'(lambda (c)
                               (declare (ignore c))
                               (invoke-restart 'store-value "eat this")))
                          (error #'(lambda (c)
                                     (declare (ignore c))
                                     (return-from tag nil))))
             (let ((var '(a b c)))
               (check-type var vector)
               var)))
         "eat this")


;; ignore-errors
(null (ignore-errors))
(ignore-errors t)
(let ((result (multiple-value-list (ignore-errors (error "error")))))
  (and (null (first result))
       (typep (second result) 'simple-error)))
(equal (multiple-value-list (ignore-errors 'a 'b 'c (values 'd 'e)))
       '(d e))
(let ((result (multiple-value-list
               (ignore-errors (signal 'simple-error
                                      :format-control "error"
                                      :format-arguments nil)))))
  (and (null (first result))
       (typep (second result) 'simple-error)))
(eq (ignore-errors (signal "only signal") 'ok) 'ok)
(eq (block tag
      (handler-bind ((condition #'(lambda (c)
                                    (declare (ignore c))
                                    (return-from tag 'handled))))
        (ignore-errors (error 'simple-condition
                              :format-control "only condition"
                              :format-arguments nil))))
    'handled)
(let ((result (multiple-value-list
               (ignore-errors (warn 'simple-error
                                    :format-control "an error, not a warning"
                                    :format-arguments nil)))))
  (and (null (first result))
       (typep (second result) 'type-error)))