Commit d501d79c authored by pfdietz's avatar pfdietz
Browse files

More find-class tests, mostly of (setf (find-class ...) ...) and its...

More find-class tests, mostly of (setf (find-class ...) ...) and its interaction with some other things.
parent 44ac5fed
......@@ -112,3 +112,169 @@
;;; Changing to NIL (and that the class object stays around)
;;; Check that find-class is affected by the assignment, and
;;; class-name is not.
(deftest find-class.15
(progn
(setf (find-class 'find-class-class-01) nil)
(let* ((class (eval '(defclass find-class-class-01 () ())))
(class1 (find-class 'find-class-class-01))
(class2 (setf (find-class 'find-class-class-01) class1)))
(values
(eqt class class1)
(eqt class class2)
(class-name class)
)))
t t find-class-class-01)
(deftest find-class.16
(progn
(setf (find-class 'find-class-class-01 nil) nil)
(setf (find-class 'find-class-class-01 t) nil) ;; should not throw error
(let* ((i 0)
(class (eval '(defclass find-class-class-01 () ())))
(class1 (find-class 'find-class-class-01))
(class2 (setf (find-class 'find-class-class-01 (incf i)) class1)))
(values
i
(eqt class class1)
(eqt class class2))))
1 t t)
(deftest find-class.17
(macrolet
((%m (&environment env)
`',(progn
(setf (find-class 'find-class-class-01) nil)
(let*
((i 0)
x y z
(class (eval '(defclass find-class-class-01 () ())))
(class1 (find-class (progn (setf x (incf i))
'find-class-class-01)
(setf y (incf i))
(progn (setf z (incf i)) env)))
(class2 (setf (find-class 'find-class-class-01) class1)))
(list
(eqt class class1)
(eqt class class2)
i x y z
)))))
(%m))
(t t 3 1 2 3))
(deftest find-class.18
(progn
(setf (find-class 'find-class-class-01) nil)
(let* ((class (eval '(defclass find-class-class-01 () ())))
(class1 (find-class 'find-class-class-01))
(class2 (setf (find-class 'find-class-class-01) nil))
(class3 (find-class 'find-class-class-01 nil)))
(values
(eqt class class1)
(eqt class class2)
class2
(class-name class)
class3)))
t nil nil find-class-class-01 nil)
(deftest find-class.19
(progn
(setf (find-class 'find-class-class-01 nil) nil)
(setf (find-class 'find-class-class-01 t) nil) ;; should not throw error
(let* ((class (eval '(defclass find-class-class-01 () ())))
(class1 (find-class 'find-class-class-01))
(class2 (setf (find-class 'find-class-class-01 t nil)
class1)))
(values
(eqt class class1)
(eqt class class2))))
t t)
;; Change to a different class
(deftest find-class.20
(progn
(setf (find-class 'find-class-class-01) nil)
(setf (find-class 'find-class-class-02) nil)
(let* ((class1 (eval '(defclass find-class-class-01 () ())))
(class2 (eval '(defclass find-class-class-02 () ()))))
(setf (find-class 'find-class-class-01) class2)
(let* ((new-class1 (find-class 'find-class-class-01 nil))
(new-class2 (find-class 'find-class-class-02)))
(values
(eqt class1 class2)
(eqt class2 new-class1)
(eqt class2 new-class2)
(class-name class2)))))
nil t t find-class-class-02)
(deftest find-class.21
(progn
(setf (find-class 'find-class-class-01) nil)
(setf (find-class 'find-class-class-02) nil)
(let* ((class1 (eval '(defclass find-class-class-01 () ())))
(class2 (eval '(defclass find-class-class-02 () ()))))
(psetf (find-class 'find-class-class-01) class2
(find-class 'find-class-class-02) class1)
(let* ((new-class1 (find-class 'find-class-class-01 nil))
(new-class2 (find-class 'find-class-class-02)))
(values
(eqt class1 class2)
(eqt class2 new-class1)
(eqt class1 new-class2)
(class-name new-class1)
(class-name new-class2)
))))
nil t t find-class-class-02 find-class-class-01)
;;; Effect on method dispatch
(deftest find-class.22
(progn
(setf (find-class 'find-class-class-01) nil)
(let* ((class1 (eval
'(defclass find-class-class-01 () ())))
(fn (eval '(defgeneric find-class-gf-01 (x)
(:method ((x find-class-class-01)) :good)
(:method ((x t)) nil))))
(obj (make-instance class1)))
(values
(funcall fn nil)
(funcall fn obj)
(setf (find-class 'find-class-class-01) nil)
(funcall fn nil)
(funcall fn obj))))
nil :good nil nil :good)
(deftest find-class.23
(progn
(setf (find-class 'find-class-class-01) nil)
(setf (find-class 'find-class-class-02) nil)
(let* ((class1 (eval '(defclass find-class-class-01 () ())))
(class2 (eval '(defclass find-class-class-02
(find-class-class-01) ())))
(fn (eval '(defgeneric find-class-gf-02 (x)
(:method ((x find-class-class-01)) 1)
(:method ((x find-class-class-02)) 2)
(:method ((x t)) t))))
(obj1 (make-instance class1))
(obj2 (make-instance class2)))
(values
(funcall fn nil)
(funcall fn obj1)
(funcall fn obj2)
(setf (find-class 'find-class-class-01) nil)
(funcall fn nil)
(funcall fn obj1)
(funcall fn obj2))))
t 1 2 nil t 1 2)
;;; Error tests
(deftest find-class.error.1
(classify-error (find-class))
program-error)
(deftest find-class.error.2
(classify-error (find-class 'symbol nil nil nil))
program-error)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment