0.8.13.72: MORE CHAPTERS

[sbcl.git] / tests / condition.pure.lisp

diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp
index a36bd71..310562d 100644 (file)
--- a/tests/condition.pure.lisp
+++ b/tests/condition.pure.lisp
@@ -20,3 +20,105 @@
 (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))
+
+;;; clauses in HANDLER-CASE are allowed to have declarations (and
+;;; indeed, only declarations)
+(assert 
+ (null (handler-case (error "foo") (error () (declare (optimize speed))))))
+
+(handler-case
+    (handler-bind ((warning #'muffle-warning))
+      (signal 'warning))
+  ;; if it's a control error, it had better be printable
+  (control-error (c) (format nil "~A" c))
+  ;; there had better be an error
+  (:no-error (&rest args) (error "No error: ~S" args)))
+
+(handler-case
+    (funcall (lambda (x) (check-type x fixnum) x) t)
+  (type-error (c)
+    (assert (and (subtypep (type-error-expected-type c) 'fixnum)
+                (subtypep 'fixnum (type-error-expected-type c))))
+    (assert (eq (type-error-datum c) t)))
+  (:no-error (&rest rest) (error "no error: ~S" rest)))