X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcondition.pure.lisp;h=88fba5b4c64bac63f67a0a39ce7fd4ed77dff16c;hb=f42374639ed3c17feee330939df92117a0055d02;hp=835818e72d65304a586a9a3a8daeca5916d0954f;hpb=c4776b3b3121be1c3bad293a4fa7efffb592f7f7;p=sbcl.git

diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp
index 835818e..88fba5b 100644
--- a/tests/condition.pure.lisp
+++ b/tests/condition.pure.lisp
@@ -145,21 +145,91 @@
 
 ;;; If CERROR is given a condition, any remaining arguments are only
 ;;; used for the continue format control.
-(let ((x 0))
-  (handler-bind
-      ((simple-error (lambda (c) (incf x) (continue c))))
-    (cerror "Continue from ~A at ~A"
-            (make-condition 'simple-error :format-control "foo"
-                            :format-arguments nil)
-            'cerror (get-universal-time))
-    (assert (= x 1))))
-
-(with-test (:name :malformed-restart-case-clause)
-  (assert (eq :ok
+(with-test (:name (cerror :condition-object-and-format-arguments))
+  (let ((x 0))
+    (handler-bind
+        ((simple-error (lambda (c) (incf x) (continue c))))
+      (cerror "Continue from ~A at ~A"
+              (make-condition 'simple-error :format-control "foo"
+                                            :format-arguments nil)
+              'cerror (get-universal-time))
+      (assert (= x 1)))))
+
+;; Test some of the variations permitted by the RESTART-CASE syntax.
+(with-test (:name (restart-case :smoke))
+  (macrolet
+      ((test (clause &optional (expected ''(:ok)) (args '(:ok)))
+         `(assert (equal ,expected
+                         (multiple-value-list
+                          (restart-case
+                              (handler-bind
+                                  ((error (lambda (c)
+                                            (invoke-restart ',(first clause) ,@args))))
+                                (error "foo"))
+                            ,clause))))))
+
+    (test (foo (quux) quux))
+    (test (foo (&optional quux) quux))
+    ;; Multiple values should work.
+    (test (foo (a b) (values a b)) '(1 2) (1 2))
+    ;; Although somewhat unlikely, these should be legal and return
+    ;; the respective keyword when the restart is invoked.
+    (test (foo () :report) '(:report) ())
+    (test (foo () :interactive) '(:interactive) ())
+    (test (foo () :test) '(:test) ())
+    ;; Declarations should work normally as part of the restart body.
+    (test (foo (quux) :declare ()) '(nil))
+    (test (foo () :declare () :report "quux") '("quux") ())))
+
+(with-test (:name (restart-case :malformed-clauses))
+  (macrolet
+      ((test (clause &optional (expected clause))
+         `(assert (eq :ok
+                      (handler-case
+                          (macroexpand
+                           `(restart-case (error "foo") ,',clause))
+                        (simple-error (e)
+                          (assert (equal '(restart-case ,expected)
+                                         (simple-condition-format-arguments e)))
+                          :ok))))))
+
+    (test :report)                     ; not even a list
+    (test ())                          ; empty
+    (test (foo))                       ; no lambda-list
+    (test (foo :report))               ; no lambda-list
+    (test (foo :report "quux"))        ; no lambda-list
+    (test (foo :report "quux" (quux))) ; confused report and lambda list
+    ))
+
+(with-test (:name :simple-condition-without-args)
+  (let ((sc (make-condition 'simple-condition)))
+    (assert (not (simple-condition-format-control sc)))
+    (assert (not (simple-condition-format-arguments sc)))
+    (assert (stringp (prin1-to-string sc)))
+    (assert
+     (eq :ok
+         (handler-case
+             (princ-to-string sc)
+           (simple-error (c)
+             (when (and (equal "No format-control for ~S"
+                               (simple-condition-format-control c))
+                        (eq sc (car
+                                (simple-condition-format-arguments c))))
+               :ok)))))))
+
+(with-test (:name :malformed-simple-condition-printing-type-error)
+  (assert (eq :type-error
               (handler-case
-                  (macroexpand `(restart-case (error "foo")
-                                  (foo :report "quux" (quux))))
-                (simple-error (e)
-                  (assert (equal '(restart-case (foo :report "quux" (quux)))
-                                 (simple-condition-format-arguments e)))
-                  :ok)))))
+                  (princ-to-string
+                   (make-condition 'simple-error :format-control "" :format-arguments 8))
+                (type-error (e)
+                  (when (and (eq 'list (type-error-expected-type e))
+                             (eql 8 (type-error-datum e)))
+                    :type-error))))))
+
+(with-test (:name (:printing-unintitialized-condition :bug-1184586))
+  (prin1-to-string (make-condition 'simple-type-error)))
+
+(with-test (:name (:print-undefined-function-condition))
+  (handler-case (funcall '#:foo)
+    (undefined-function (c) (princ c))))