X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcondition.pure.lisp;h=043080019c14b9558c671055237b2123fa7566ed;hb=a189a69454ef7635149319ae213b337f17c50d20;hp=cddc4be1227413119d980379093dd3f4ec0c6fc6;hpb=ed2e811980a924df922505d6cc52fef8c76d85b5;p=sbcl.git diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp index cddc4be..0430800 100644 --- a/tests/condition.pure.lisp +++ b/tests/condition.pure.lisp @@ -6,20 +6,22 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. (cl:in-package :cl-user) +(load "test-util.lisp") + ;;; Until 0.7.7.21, (MAKE-CONDITION 'FILE-ERROR :PATHNAME "FOO") ;;; wasn't printable, because the REPORT function for FILE-ERROR ;;; referred to unbound slots. This was reported and fixed by Antonio ;;; Martinez (sbcl-devel 2002-09-10). (format t - "~&printable now: ~A~%" - (make-condition 'file-error :pathname "foo")) + "~&printable now: ~A~%" + (make-condition 'file-error :pathname "foo")) (assert (eq (block nil @@ -49,6 +51,7 @@ (foo2 (make-condition 'error))) (handler-bind ((error (lambda (c) + (declare (ignore c)) (let ((restarts (remove 'res (compute-restarts foo1) :key #'restart-name :test-not #'eql))) @@ -94,8 +97,11 @@ (assert (eq (block nil (handler-bind - ((type-error (lambda (c) (return :failed))) + ((type-error (lambda (c) + (declare (ignore c)) + (return :failed))) (simple-error (lambda (c) + (declare (ignore c)) (return (if (find-restart 'continue) :passed :failed))))) @@ -104,7 +110,7 @@ ;;; clauses in HANDLER-CASE are allowed to have declarations (and ;;; indeed, only declarations) -(assert +(assert (null (handler-case (error "foo") (error () (declare (optimize speed)))))) (handler-case @@ -119,7 +125,7 @@ (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)))) + (subtypep 'fixnum (type-error-expected-type c)))) (assert (eq (type-error-datum c) t))) (:no-error (&rest rest) (error "no error: ~S" rest))) @@ -127,13 +133,13 @@ ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp ;;; 2004-10-12. (flet ((test (&rest args) - (multiple-value-bind (res err) + (multiple-value-bind (res err) (ignore-errors (apply #'error args)) (assert (not res)) (assert (typep err 'type-error)) - (assert (not (nth-value 1 (ignore-errors + (assert (not (nth-value 1 (ignore-errors (type-error-datum err))))) - (assert (not (nth-value 1 (ignore-errors + (assert (not (nth-value 1 (ignore-errors (type-error-expected-type err)))))))) (test '#:no-such-condition) (test nil) @@ -143,11 +149,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 (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 + (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))))