Commit 8e4334b2 authored by pfdietz's avatar pfdietz
Browse files

More tests of defclass, mostly of inheritance.

parent c69a7873
......@@ -791,9 +791,40 @@
(typep* #'(setf s1-26) 'generic-function)))
nil x x t)
;;;
\ No newline at end of file
(defclass class-27 ()
(a (b :initform 10) (c :initarg :c) (d :initarg :d))
(:metaclass standard-class)
(:default-initargs :d 17))
(deftest class-27.1
(let ((class (find-class 'class-27)))
(values
(subtypep* 'class-27 'standard-object)
(subtypep* 'class-27 t)
(subtypep* 'class-27 (find-class 'standard-object))
(subtypep* 'class-27 (find-class t))
(subtypep* class 'standard-object)
(subtypep* class t)
(subtypep* class (find-class 'standard-object))
(subtypep* class (find-class t))))
t t t t t t t t)
(deftest class-27.2
(let ((c (make-instance 'class-27)))
(values
(slot-boundp* c 'a)
(slot-value c 'b)
(slot-boundp* c 'c)
(slot-value c 'd)))
nil 10 nil 17)
(deftest class-27.3
(let ((c (make-instance 'class-27 :c 26 :d 43)))
(values
(slot-boundp* c 'a)
(slot-value c 'b)
(slot-value c 'c)
(slot-value c 'd)))
nil 10 26 43)
......@@ -315,6 +315,30 @@
z
x y z)))
;;; Same as class-redefinition.1, but reverse the order in which
;;; the classes are redefined.
(deftest class-redefinition.3
(let*
((cobj1 (eval '(defclass class-redef-03a ()
((a :allocation :class :initform 'x)))))
(cobj2 (eval '(defclass class-redef-03b (class-redef-03a)
((a :allocation :instance)))))
(cobj4 (eval '(defclass class-redef-03b (class-redef-03a)
((a :allocation :instance)))))
(cobj3 (eval '(defclass class-redef-03a ()
((a :allocation :class :initform 'x))))))
(values
(eqt cobj1 cobj3)
(eqt cobj2 cobj4)
(class-name cobj1)
(class-name cobj2)
(slot-value (make-instance 'class-redef-03a) 'a)
(slot-value (make-instance 'class-redef-03b) 'a)))
t t
class-redef-03a
class-redef-03b
x x)
;;; Initforms are inherited even if :allocation changes
(defclass class-0211a ()
......@@ -329,3 +353,363 @@
(slot-value (make-instance 'class-0211b) 'a))
x x)
;;;
;;; Inheritance of :initargs
(defclass class-0212a ()
((a :initarg :a1)))
(defclass class-0212b (class-0212a)
((a :initarg :a2)
(b :initarg :b)))
(deftest class-0212.1
(let ((c (make-instance 'class-0212a :a1 'x)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-exists-p c 'b)))
t nil x nil)
(deftest class-0212.2
(let ((c (make-instance 'class-0212b :a1 'x)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-boundp* c 'b)))
t t x nil)
(deftest class-0212.3
(let ((c (make-instance 'class-0212b :a2 'x :b 'y)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-value c 'b)))
t t x y)
(deftest class-0212.4
(let ((c (make-instance 'class-0212b :a1 'z :a2 'x :b 'y)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-value c 'b)))
t t z y)
(deftest class-0212.5
(let ((c (make-instance 'class-0212b :a2 'x :b 'y :a1 'z)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-value c 'b)))
t t x y)
;;;
(defclass class-0213a ()
((a :initarg :a1)))
(defclass class-0213b (class-0213a)
(b))
(deftest class-0213.1
(let ((c (make-instance 'class-0213a :a1 'x)))
(values
(typep* c 'class-0213a)
(typep* c 'class-0213b)
(slot-value c 'a)
(slot-exists-p c 'b)))
t nil x nil)
(deftest class-0213.2
(let ((c (make-instance 'class-0213b :a1 'x)))
(values
(typep* c 'class-0213a)
(typep* c 'class-0213b)
(slot-value c 'a)
(slot-boundp* c 'b)))
t t x nil)
;;;
(defclass class-0214a ()
((a :initarg :a1 :allocation :class)))
(defclass class-0214b (class-0214a)
(b))
(deftest class-0214.1
(let ((c (make-instance 'class-0214a :a1 'x)))
(values
(typep* c 'class-0214a)
(typep* c 'class-0214b)
(slot-value c 'a)
(slot-exists-p c 'b)))
t nil x nil)
(deftest class-0214.2
(let ((c (make-instance 'class-0214b :a1 'y)))
(values
(typep* c 'class-0214a)
(typep* c 'class-0214b)
(slot-value c 'a)
(slot-boundp* c 'b)))
t t y nil)
;;;
(defclass class-0215a ()
((a :initarg :a1 :allocation :instance)))
(defclass class-0215b (class-0215a)
((a :allocation :class)))
(deftest class-0215.1
(let ((c (make-instance 'class-0215a :a1 'x)))
(values
(typep* c 'class-0215a)
(typep* c 'class-0215b)
(slot-value c 'a)))
t nil x)
(deftest class-0215.2
(let ((c (make-instance 'class-0215b :a1 'y)))
(values
(typep* c 'class-0215a)
(typep* c 'class-0215b)
(slot-value c 'a)))
t t y)
;;; Tests of defaulted initargs
(defclass class-0216a ()
((a :initarg :a1)
(b :initarg :b1)))
(defclass class-0216b (class-0216a)
()
(:default-initargs :a1 'x))
(deftest class-0216.1
(let ((c (make-instance 'class-0216a)))
(values
(typep* c 'class-0216a)
(typep* c 'class-0216b)
(slot-boundp c 'a)
(slot-boundp c 'b)))
t nil nil nil)
(deftest class-0216.2
(let ((c (make-instance 'class-0216b)))
(values
(typep* c 'class-0216a)
(typep* c 'class-0216b)
(slot-value c 'a)
(slot-boundp c 'b)))
t t x nil)
;;;
(defclass class-0217a ()
((a :initarg :a1)
(b :initarg :b1)
(c :initarg :c1)
(d :initarg :d1))
(:default-initargs :a1 10 :b1 20))
(defclass class-0217b (class-0217a)
()
(:default-initargs :a1 30 :c1 40))
(deftest class-0217.1
(let ((c (make-instance 'class-0217a)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b))))
(t t nil nil)
(10 20))
(deftest class-0217.2
(let ((c (make-instance 'class-0217a :a1 'x :c1 'y)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c))))
(t t t nil)
(x 20 y))
(deftest class-0217.3
(let ((c (make-instance 'class-0217b)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c))))
(t t t nil)
(30 20 40))
(deftest class-0217.4
(let ((c (make-instance 'class-0217b :a1 'x :d1 'y)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c d))))
(t t t t)
(x 20 40 y))
;;;
(defclass class-0218a ()
((a :initarg :a1))
(:default-initargs :a1 'x))
(defclass class-0218b (class-0218a)
((a :initform 'y)))
(deftest class-0218.1
(let ((c (make-instance 'class-0218a)))
(slot-value c 'a))
x)
(deftest class-0218.2
(let ((c (make-instance 'class-0218b)))
(slot-value c 'a))
x)
;;;
(declaim (special *class-0219-a-1* *class-0219-a-2*))
(defclass class-0219a ()
((a :initarg :a1))
(:default-initargs :a1 (setf *class-0219-a-1* 'x)))
(defclass class-0219b ()
((a :initarg :a1))
(:default-initargs :a1 (setf *class-0219-a-2* 'y)))
(deftest class-0219.1
(let ((*class-0219-a-1* nil))
(values
(slot-value (make-instance 'class-0219a) 'a)
*class-0219-a-1*))
x x)
(deftest class-0219.2
(let ((*class-0219-a-1* nil)
(*class-0219-a-2* nil))
(values
(slot-value (make-instance 'class-0219b) 'a)
*class-0219-a-1*
*class-0219-a-2*))
y nil y)
;;;
(defclass class-0220a ()
((a :type (integer 0 10) :initarg :a)))
(defclass class-0220b (class-0220a)
((a :type (integer -5 5))))
(deftest class-0220.1
(slot-value (make-instance 'class-0220a :a 10) 'a)
10)
(deftest class-0220.2
(slot-value (make-instance 'class-0220a :a 0) 'a)
0)
(deftest class-0220.3
(slot-value (make-instance 'class-0220b :a 0) 'a)
0)
(deftest class-0220.4
(slot-value (make-instance 'class-0220b :a 5) 'a)
5)
;;;
(defclass class-0221a ()
(a b c)
(:documentation "This is class class-0221a"))
(defclass class-0221b (class-0221a)
())
(defclass class-0221c (class-0221a)
()
(:documentation "This is class class-0221c"))
(deftest class-0221.1
(let* ((cl (find-class 'class-0221a))
(doc (documentation cl t)))
(or (null doc)
(equalt doc "This is class class-0221a")))
t)
(deftest class-0221.2
(let* ((cl (find-class 'class-0221b))
(doc (documentation cl t)))
doc)
nil)
(deftest class-0221.3
(let* ((cl (find-class 'class-0221c))
(doc (documentation cl t)))
(or (null doc)
(equalt doc "This is class class-0221c")))
t)
;;;
(defclass class-0222a ()
((s1 :reader s1-r :writer s1-w :accessor s1-acc)))
(defclass class-0222b (class-0222a)
())
(deftest class-0222.1
(let ((c (make-instance 'class-0222a)))
(values
(s1-w 'x c)
(s1-r c)
(s1-acc c)
(setf (s1-acc c) 'y)
(s1-r c)))
x x x y y)
(deftest class-0222.2
(let ((c (make-instance 'class-0222b)))
(values
(s1-w 'x c)
(s1-r c)
(s1-acc c)
(setf (s1-acc c) 'y)
(s1-r c)))
x x x y y)
;;;
(defclass class-0223a ()
((s1 :reader s-r :writer s-w :accessor s-acc)))
(defclass class-0223b (class-0223a)
((s2 :reader s-r :writer s-w :accessor s-acc)))
(deftest class-0223.1
(let ((c (make-instance 'class-0223b)))
(values
(setf (slot-value c 's1) 'x)
(setf (slot-value c 's2) 'y)
(s-r c)
(s-acc c)
(s-w 'z c)
(slot-value c 's1)
(slot-value c 's2)
(s-r c)
(s-acc c)))
x y y y z x z z z)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Apr 27 16:23:59 2003
;;;; Contains: Tests of DEFCLASS with more involved inheritance
(in-package :cl-test)
;;;
(defclass class-0301a ()
(a b))
(defclass class-0301b ()
(a c))
(defclass class-0301c (class-0301a class-0301b)
(d))
(deftest class-0301.1
(let ((c (make-instance 'class-0301c)))
(values
(typep* c 'class-0301a)
(typep* c 'class-0301b)
(typep* c 'class-0301c)
(typep* c (find-class 'class-0301a))
(typep* c (find-class 'class-0301b))
(typep* c (find-class 'class-0301c))
(map-slot-boundp* c '(a b c d))
(setf (slot-value c 'a) 'w)
(setf (slot-value c 'b) 'x)
(setf (slot-value c 'c) 'y)
(setf (slot-value c 'd) 'z)
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c d))))
t t t
t t t
(nil nil nil nil)
w x y z
(t t t t)
(w x y z))
;;;
(defclass class-0302a ()
((a :initform 'x) b (c :initform 'w)))
(defclass class-0302b ()
((a :initform 'y) (b :initform 'z)))
(defclass class-0302c (class-0302a class-0302b)
(a b (c :initform 'v) d))
(deftest class-0302.1
(let ((c (make-instance 'class-0302c)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c))))
(t t t nil)
(x z v))
;;;
(defclass class-0303a ()
((a :allocation :class) b))
(defclass class-0303b ()
(a (b :allocation :class)))
(defclass class-0303c (class-0303a class-0303b) ())
(deftest class-0303.1
(let ((c1 (make-instance 'class-0303a))
(c2 (make-instance 'class-0303b))
(c3 (make-instance 'class-0303c)))
(slot-makunbound c1 'a)
(slot-makunbound c2 'b)
(values
(loop for c in (list c1 c2 c3)
collect (map-slot-boundp* c '(a b)))
(list (setf (slot-value c1 'a) 'x1)
(slot-boundp* c2 'a)
(slot-value c3 'a))
(list (setf (slot-value c2 'a) 'x2)
(slot-value c1 'a)
(slot-value c2 'a)
(slot-value c3 'a))
(list (setf (slot-value c3 'a) 'x3)
(slot-value c1 'a)
(slot-value c2 'a)
(slot-value c3 'a))
;;;
(list (setf (slot-value c1 'b) 'y1)
(slot-value c1 'b)
(slot-boundp* c2 'b)
(slot-boundp* c3 'b))
(list (setf (slot-value c2 'b) 'y2)
(slot-value c1 'b)
(slot-value c2 'b)
(slot-boundp c3 'b))
(list (setf (slot-value c3 'b) 'y3)
(slot-value c1 'b)
(slot-value c2 'b)
(slot-value c3 'b))))
((nil nil) (nil nil) (nil nil))
(x1 nil x1)
(x2 x1 x2 x1)
(x3 x3 x2 x3)
;;
(y1 y1 nil nil)
(y2 y1 y2 nil)
(y3 y1 y2 y3))
;;;
(defclass class-0304a ()
((a :initform 'x)))
(defclass class-0304b (class-0304a) ())
(defclass class-0304c (class-0304a)
((a :initform 'y)))
(defclass class-0304d (class-0304b class-0304c)
())
(deftest class-0304.1
(slot-value (make-instance 'class-0304d) 'a)
y)
;;;
(defclass class-0305a ()
((a :initarg :a))
(:default-initargs :a 'x))
(defclass class-0305b (class-0305a) ())
(defclass class-0305c (class-0305a)
()
(:default-initargs :a 'y))
(defclass class-0305d (class-0305b class-0305c)
())
(deftest class-0305.1
(slot-value (make-instance 'class-0305d) 'a)
y)
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