Add Sacla to the repository.

1 files changed, 898 insertions, 0 deletions

diff --git a/Sacla/tests/must-condition.lisp b/Sacla/tests/must-condition.lisp
new file mode 100644
index 0000000..08e7080
--- /dev/null
+++ b/Sacla/tests/must-condition.lisp
@@ -0,0 +1,898 @@
+;; 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)))
+