source: trunk/source/tests/ansi-tests/defclass-03.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 6.4 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Apr 27 16:23:59 2003
4;;;; Contains: Tests of DEFCLASS with more involved inheritance
5
6(in-package :cl-test)
7
8;;;
9
10(defclass class-0301a ()
11  (a b))
12
13(defclass class-0301b ()
14  (a c))
15
16(defclass class-0301c (class-0301a class-0301b)
17  (d))
18
19(deftest class-0301.1
20  (let ((c (make-instance 'class-0301c)))
21    (values
22     (typep* c 'class-0301a)
23     (typep* c 'class-0301b)
24     (typep* c 'class-0301c)
25     (typep* c (find-class 'class-0301a))
26     (typep* c (find-class 'class-0301b))
27     (typep* c (find-class 'class-0301c))
28     (map-slot-boundp* c '(a b c d))
29     (setf (slot-value c 'a) 'w)
30     (setf (slot-value c 'b) 'x)
31     (setf (slot-value c 'c) 'y)
32     (setf (slot-value c 'd) 'z)
33     (map-slot-boundp* c '(a b c d))
34     (map-slot-value c '(a b c d))))
35  t t t
36  t t t
37  (nil nil nil nil)
38  w x y z
39  (t t t t)
40  (w x y z))
41
42;;;
43
44(defclass class-0302a ()
45  ((a :initform 'x) b (c :initform 'w)))
46
47(defclass class-0302b ()
48  ((a :initform 'y) (b :initform 'z)))
49
50(defclass class-0302c (class-0302a class-0302b)
51  (a b (c :initform 'v) d))
52
53(deftest class-0302.1
54  (let ((c (make-instance 'class-0302c)))
55    (values
56     (map-slot-boundp* c '(a b c d))
57     (map-slot-value c '(a b c))))
58  (t t t nil)
59  (x z v))
60
61;;;
62
63(defclass class-0303a ()
64  ((a :allocation :class) b))
65
66(defclass class-0303b ()
67  (a (b :allocation :class)))
68
69(defclass class-0303c (class-0303a class-0303b) ())
70
71(deftest class-0303.1
72  (let ((c1 (make-instance 'class-0303a))
73        (c2 (make-instance 'class-0303b))
74        (c3 (make-instance 'class-0303c)))
75    (slot-makunbound c1 'a)
76    (slot-makunbound c2 'b)
77    (values
78     (loop for c in (list c1 c2 c3)
79           collect (map-slot-boundp* c '(a b)))
80     (list (setf (slot-value c1 'a) 'x1)
81           (slot-boundp* c2 'a)
82           (slot-value c3 'a))
83     (list (setf (slot-value c2 'a) 'x2)
84           (slot-value c1 'a)
85           (slot-value c2 'a)
86           (slot-value c3 'a))
87     (list (setf (slot-value c3 'a) 'x3)
88           (slot-value c1 'a)
89           (slot-value c2 'a)
90           (slot-value c3 'a))
91     ;;;
92     (list (setf (slot-value c1 'b) 'y1)
93           (slot-value c1 'b)
94           (slot-boundp* c2 'b)
95           (slot-boundp* c3 'b))
96     (list (setf (slot-value c2 'b) 'y2)
97           (slot-value c1 'b)
98           (slot-value c2 'b)
99           (slot-boundp c3 'b))
100     (list (setf (slot-value c3 'b) 'y3)
101           (slot-value c1 'b)
102           (slot-value c2 'b)
103           (slot-value c3 'b))))
104  ((nil nil) (nil nil) (nil nil))
105  (x1 nil x1)
106  (x2 x1 x2 x1)
107  (x3 x3 x2 x3)
108  ;;
109  (y1 y1 nil nil)
110  (y2 y1 y2 nil)
111  (y3 y1 y2 y3))
112
113;;;
114
115(defclass class-0304a ()
116  ((a :initform 'x)))
117
118(defclass class-0304b (class-0304a) ())
119
120(defclass class-0304c (class-0304a)
121  ((a :initform 'y)))
122
123(defclass class-0304d (class-0304b class-0304c)
124  ())
125
126(deftest class-0304.1
127  (slot-value (make-instance 'class-0304d) 'a)
128  y)
129
130;;;
131
132(defclass class-0305a ()
133  ((a :initarg :a))
134  (:default-initargs :a 'x))
135
136(defclass class-0305b (class-0305a) ())
137
138(defclass class-0305c (class-0305a)
139  ()
140  (:default-initargs :a 'y))
141
142(defclass class-0305d (class-0305b class-0305c)
143  ())
144
145(deftest class-0305.1
146  (slot-value (make-instance 'class-0305d) 'a)
147  y)
148
149
150;;; A test showing nonmonotonicity in the CLOS CPL algorithm
151
152(defclass class-0306a () ((a :initform nil :reader a-slot)))
153(defclass class-0306b (class-0306a) ((a :initform 'x)))
154(defclass class-0306c (class-0306a) ((a :initform 'y)))
155(defclass class-0306d (class-0306b) ())
156(defclass class-0306e (class-0306b) ())
157(defclass class-0306f (class-0306d class-0306c) ())
158(defclass class-0306g (class-0306e) ())
159(defclass class-0306h (class-0306f class-0306g) ())
160
161;;; Class class-0306c should precede class-0306b in the
162;;; CPL for class-0306h, even though it follows it in the CPLs
163;;; for the direct superclasses of class-0306h.
164
165(deftest class-0306.1
166  (loop for obj in
167        (mapcar #'make-instance
168             '(class-0306a class-0306b class-0306c class-0306d
169               class-0306e class-0306f class-0306g class-0306h))
170        collect (slot-value obj 'a))
171  (nil x y x x x x y))
172
173(deftest class-0306.2
174  (loop for obj in
175        (mapcar #'make-instance
176             '(class-0306a class-0306b class-0306c class-0306d
177               class-0306e class-0306f class-0306g class-0306h))
178        collect (a-slot obj))
179  (nil x y x x x x y))
180
181;;; A class redefinition test that came up in cmucl
182
183(deftest class-0307.1
184  (progn
185    (setf (find-class 'class-0307a) nil
186          (find-class 'class-0307b) nil)
187    (eval '(defclass class-0307a () ()))
188    (eval '(defclass class-0307b (class-0307a) (a)))
189    (eval '(defclass class-0307a () ((a :initform nil))))
190    (eval '(defclass class-0307b (class-0307a) ((a :initform 'x))))
191    (slot-value (make-instance 'class-0307b) 'a))
192  x)
193
194(deftest class-0308.1
195  (progn
196    (setf (find-class 'class-0308a) nil
197          (find-class 'class-0308b) nil)
198    (eval '(defclass class-0308a () ()))
199    (eval '(defclass class-0308b (class-0308a) (a)))
200    (eval '(defclass class-0308a () ((a :initarg :a))))
201    (eval '(defclass class-0308b (class-0308a) ()))
202    (slot-value (make-instance 'class-0308b :a 'x) 'a))
203  x)
204
205;;; More class redefinition tests
206
207(deftest class-0309.1
208  (progn
209    (setf (find-class 'class-0309) nil)
210    (let* ((class1 (eval '(defclass class-0309 () ((a) (b) (c)))))
211           (obj1 (make-instance 'class-0309)))
212      (setf (class-name class1) nil)
213      (let ((class2 (eval '(defclass class-0309 () ((a) (b) (c))))))
214        (values
215         (eqt (class-of obj1) class1)
216         (eqt class1 class2)
217         (typep* obj1 class1)
218         (typep* obj1 class2)))))
219  t nil t nil)
220
221(deftest class-0310.1
222  (progn
223    (setf (find-class 'class-0310a) nil
224          (find-class 'class-0310b) nil)
225    (let* ((class1 (eval '(defclass class-0310a () ((a) (b) (c)))))
226           (obj1 (make-instance 'class-0310a)))
227      (setf (class-name class1) 'class-0310b)
228      (let ((class2 (eval '(defclass class-0310a () ((a) (b) (c))))))
229        (values
230         (eqt (class-of obj1) class1)
231         (eqt class1 class2)
232         (typep* obj1 class1)
233         (typep* obj1 class2)
234         (class-name class1)
235         (class-name class2)))))
236  t nil t nil class-0310b class-0310a)
237
238(deftest class-0311.1
239  (progn
240    (setf (find-class 'class-0311) nil)
241    (let* ((class1 (eval '(defclass class-0311 () ((a) (b) (c)))))
242           (obj1 (make-instance 'class-0311)))
243      (setf (find-class 'class-0311) nil)
244      (let ((class2 (eval '(defclass class-0311 () ((a) (b) (c))))))
245        (values
246         (eqt (class-of obj1) class1)
247         (eqt class1 class2)
248         (typep* obj1 class1)
249         (typep* obj1 class2)
250         (class-name class1)
251         (class-name class2)
252         (eqt (find-class 'class-0311) class1)
253         (eqt (find-class 'class-0311) class2)))))
254  t nil t nil class-0311 class-0311 nil t)
Note: See TracBrowser for help on using the repository browser.