X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcondition.impure.lisp;h=10825ed93ee24a3608d79b9df5c8301ef6bd88b6;hb=062283b901155792f65775491aea51481c56faaa;hp=ae332c30ff63d941196077dd97378657675bceda;hpb=9bdd2579f980573a74daabe03120ed64b1733b11;p=sbcl.git diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index ae332c3..10825ed 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -51,27 +51,42 @@ '(and condition counted-condition))) (define-condition picky-condition () ()) -(restart-case - (handler-case - (error 'picky-condition) - (picky-condition (c) - (assert (eq (car (compute-restarts)) (car (compute-restarts c)))))) - (picky-restart () - :report "Do nothing." - :test (lambda (c) - (typep c '(or null picky-condition))) - 'ok)) + +(with-test (:name (:picky-condition compute-restarts)) + (restart-case + (handler-case + (error 'picky-condition) + (picky-condition (c) + ;; The PICKY-RESTART should be applicable for the + ;; PICKY-CONDITION and all other cases. + (assert (eq (restart-name (first (compute-restarts))) 'picky-restart)) + (assert (eq (restart-name (first (compute-restarts c))) 'picky-restart)) + (assert (eq (car (compute-restarts)) (car (compute-restarts c)))) + ;; ANOTHER-PICKY-RESTART should not be applicable for the + ;; PICKY-CONDITION, but all other cases. + (assert (not (find 'another-picky-restart (compute-restarts c) + :key #'restart-name))) + (assert (find 'another-picky-restart (compute-restarts) + :key #'restart-name)) + :ok)) + (picky-restart () + :report "Do nothing." + :test (lambda (c) (typep c '(or null picky-condition)))) + (another-picky-restart () + :report "Do nothing as well" + :test (lambda (c) (typep c '(not picky-condition)))))) ;;; adapted from Helmut Eller on cmucl-imp -(assert (eq 'it - (restart-case - (handler-case - (error 'picky-condition) - (picky-condition (c) - (invoke-restart (find-restart 'give-it c)))) - (give-it () - :test (lambda (c) (typep c 'picky-condition)) - 'it)))) +(with-test (:name (:picky-condition invoke-restart)) + (assert (eq 'it + (restart-case + (handler-case + (error 'picky-condition) + (picky-condition (c) + (invoke-restart (find-restart 'give-it c)))) + (give-it () + :test (lambda (c) (typep c 'picky-condition)) + 'it))))) ;;; In sbcl-1.0.9, a condition derived from CL:STREAM-ERROR (or ;;; CL:READER-ERROR or or CL:PARSE-ERROR) didn't inherit a usable @@ -193,3 +208,120 @@ (assert (functionp (condition-with-constant-function-initform-foo (make-instance 'condition-with-constant-function-initform))))) + +;;; bug-1164969 + +(defvar bar-counter 0) + +(defvar baz-counter 0) + +(define-condition condition-with-non-constant-default-initarg () + ((bar :initarg :bar + :reader condition-with-non-constant-default-initarg-bar) + (baz :initarg :baz + :reader condition-with-non-constant-default-initarg-baz + :initform (incf baz-counter))) + (:default-initargs :bar (incf bar-counter))) +(define-condition condition-with-non-constant-default-initarg () + ((bar :initarg :bar + :reader condition-with-non-constant-default-initarg-bar) + (baz :initarg :baz + :reader condition-with-non-constant-default-initarg-baz + :initform (incf baz-counter))) + (:default-initargs :bar (incf bar-counter))) + +(with-test (:name (:redefining-condition-with-non-constant-default-initarg + :bug-1164969)) + ;; Redefining conditions could lead to multiple evaluations of + ;; initfunctions for slots and default initargs. We need all the + ;; combinations of make-condition/instance and eval/compile because + ;; they failed differently. + (macrolet ((test (case &body body) + `(progn + (setf bar-counter 0 + baz-counter 0) + (let ((instance (progn ,@body))) + (assert + (= 1 (condition-with-non-constant-default-initarg-bar + instance)) + nil + ,(format nil "Assertion failed for default initarg initfunction for ~A" + case)) + (assert + (= 1 (condition-with-non-constant-default-initarg-baz + instance)) + nil + ,(format nil "Assertion failed for slot initfunction for ~A" + case))) + (assert (= 1 bar-counter)) + (assert (= 1 baz-counter))))) + + ;; Go through EVAL to avoid optimizations. + (test :eval+make-condition + (eval '(make-condition + 'condition-with-non-constant-default-initarg))) + (test :eval+make-instance + (eval '(make-instance + 'condition-with-non-constant-default-initarg))) + + ;; Allow optimizations. + (test :compile+make-condition + (make-condition + 'condition-with-non-constant-default-initarg)) + (test :compile+make-instance + (make-instance + 'condition-with-non-constant-default-initarg)))) + +;;; bug-1049404 + +(define-condition condition-with-class-allocation () + ((count :accessor condition-with-class-allocation-count + :initform 0 + :allocation :class))) + +(with-test (:name (:condition-with-class-allocation :bug-1049404)) + (loop repeat 5 do + (incf (condition-with-class-allocation-count + (make-condition 'condition-with-class-allocation)))) + (assert (= 5 (condition-with-class-allocation-count + (make-condition 'condition-with-class-allocation))))) + +;;; bug-789497 + +(with-test (:name (assert :print-intermediate-results :bug-789497)) + (macrolet ((test (bindings expression expected-message) + `(let ,bindings + (handler-case (assert ,expression) + (simple-error (condition) + (assert (string= (princ-to-string condition) + ,expected-message))))))) + ;; Constant and variables => no special report. + (test () nil "The assertion NIL failed.") + (test ((a nil)) a "The assertion A failed.") + ;; Special operators => no special report. + (test ((a nil) (b nil)) (or a b) "The assertion (OR A B) failed.") + (test ((a nil) (b t)) (and a b) "The assertion (AND A B) failed.") + ;; Functions with constant and non-constant arguments => include + ;; non-constant arguments in report. + (test ((a t)) (not a) "The assertion (NOT A) failed with A = T.") + (test () (not t) "The assertion (NOT T) failed.") + (test ((a -1)) (plusp (signum a)) + "The assertion (PLUSP (SIGNUM A)) failed with (SIGNUM A) = -1."))) + +(with-test (:name (find-restart :recheck-conditions-and-tests :bug-774410)) + (let ((activep t)) + (restart-bind ((switchable-restart + (constantly 'irrelevant) + :test-function (lambda (condition) + (declare (ignore condition)) + activep))) + (let ((actual-restart (find-restart 'switchable-restart))) + ;; Inactive because of condition-restarts associations. + (let ((required-condition (make-condition 'condition)) + (wrong-condition (make-condition 'condition))) + (with-condition-restarts required-condition (list actual-restart) + (assert (null (find-restart actual-restart wrong-condition))))) + + ;; Inactive because of test-function. + (setf activep nil) + (assert (null (find-restart actual-restart)))))))