X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcondition.pure.lisp;h=cf6bb965849691405a8e4b4febdc819d3d6dd2e4;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=a36bd715f87e15d3e72cf0eafaf4ca3790080539;hpb=1250e993756076f6e12a6459983d9a953529ff96;p=sbcl.git

diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp
index a36bd71..cf6bb96 100644
--- a/tests/condition.pure.lisp
+++ b/tests/condition.pure.lisp
@@ -20,3 +20,84 @@
 (format t
 	"~&printable now: ~A~%"
 	(make-condition 'file-error :pathname "foo"))
+
+(assert (eq
+         (block nil
+           (macrolet ((opaque-error (arg) `(error ,arg)))
+             (handler-bind
+                 ((error (lambda (c)
+                           (let ((restarts (remove 'res (compute-restarts c)
+                                                   :key #'restart-name
+                                                   :test-not #'eql)))
+                             (assert (= (length restarts) 2))
+                             (invoke-restart (second restarts))))))
+               (let ((foo1 (make-condition 'error))
+                     (foo2 (make-condition 'error)))
+                 (restart-case
+                     (with-condition-restarts foo1 (list (find-restart 'res))
+                       (restart-case
+                           (opaque-error foo2)
+                         (res () 'int1)
+                         (res () 'int2)))
+                   (res () 'ext))))))
+         'int2))
+
+(assert (eq
+         (block nil
+           (macrolet ((opaque-error (arg) `(error ,arg)))
+             (let ((foo1 (make-condition 'error))
+                   (foo2 (make-condition 'error)))
+               (handler-bind
+                   ((error (lambda (c)
+                             (let ((restarts (remove 'res (compute-restarts foo1)
+                                                     :key #'restart-name
+                                                     :test-not #'eql)))
+                               (assert (= (length restarts) 1))
+                               (invoke-restart (first restarts))))))
+                 (restart-case
+                     (with-condition-restarts foo1 (list (find-restart 'res))
+                       (restart-case
+                           (opaque-error foo2)
+                         (res () 'int1)
+                         (res () 'int2)))
+                   (res () 'ext))))))
+         'ext))
+
+(assert (eq
+         'ext
+         (block nil
+           (let ((visible nil)
+                 (c1 (make-condition 'error))
+                 (c2 (make-condition 'error)))
+             (handler-bind
+                 ((error
+                   (lambda (c)
+                     (declare (ignore c))
+                     (flet ((check-restarts (length)
+                              (assert (= length
+                                         (length (remove 'foo (compute-restarts c1)
+                                                         :key #'restart-name
+                                                         :test-not #'eql))))))
+                       (check-restarts 1)
+                       (setq visible t)
+                       (check-restarts 1)
+                       (invoke-restart (find-restart 'foo c1))))))
+               (restart-case
+                   (restart-case
+                       (error c2)
+                     (foo () 'in1)
+                     (foo () :test (lambda (c) (declare (ignore c)) visible)
+                          'in2))
+                 (foo () 'ext)))))))
+
+;;; First argument of CERROR is a format control
+(assert
+ (eq (block nil
+       (handler-bind
+           ((type-error (lambda (c) (return :failed)))
+            (simple-error (lambda (c)
+                            (return (if (find-restart 'continue)
+                                        :passed
+                                        :failed)))))
+         (cerror (formatter "Continue from ~A") "bug ~A" :bug)))
+     :passed))