112 |
;;; Changing to NIL (and that the class object stays around) |
;;; Changing to NIL (and that the class object stays around) |
113 |
;;; Check that find-class is affected by the assignment, and |
;;; Check that find-class is affected by the assignment, and |
114 |
;;; class-name is not. |
;;; class-name is not. |
115 |
|
|
116 |
|
(deftest find-class.15 |
117 |
|
(progn |
118 |
|
(setf (find-class 'find-class-class-01) nil) |
119 |
|
(let* ((class (eval '(defclass find-class-class-01 () ()))) |
120 |
|
(class1 (find-class 'find-class-class-01)) |
121 |
|
(class2 (setf (find-class 'find-class-class-01) class1))) |
122 |
|
(values |
123 |
|
(eqt class class1) |
124 |
|
(eqt class class2) |
125 |
|
(class-name class) |
126 |
|
))) |
127 |
|
t t find-class-class-01) |
128 |
|
|
129 |
|
(deftest find-class.16 |
130 |
|
(progn |
131 |
|
(setf (find-class 'find-class-class-01 nil) nil) |
132 |
|
(setf (find-class 'find-class-class-01 t) nil) ;; should not throw error |
133 |
|
(let* ((i 0) |
134 |
|
(class (eval '(defclass find-class-class-01 () ()))) |
135 |
|
(class1 (find-class 'find-class-class-01)) |
136 |
|
(class2 (setf (find-class 'find-class-class-01 (incf i)) class1))) |
137 |
|
(values |
138 |
|
i |
139 |
|
(eqt class class1) |
140 |
|
(eqt class class2)))) |
141 |
|
1 t t) |
142 |
|
|
143 |
|
(deftest find-class.17 |
144 |
|
(macrolet |
145 |
|
((%m (&environment env) |
146 |
|
`',(progn |
147 |
|
(setf (find-class 'find-class-class-01) nil) |
148 |
|
(let* |
149 |
|
((i 0) |
150 |
|
x y z |
151 |
|
(class (eval '(defclass find-class-class-01 () ()))) |
152 |
|
(class1 (find-class (progn (setf x (incf i)) |
153 |
|
'find-class-class-01) |
154 |
|
(setf y (incf i)) |
155 |
|
(progn (setf z (incf i)) env))) |
156 |
|
(class2 (setf (find-class 'find-class-class-01) class1))) |
157 |
|
(list |
158 |
|
(eqt class class1) |
159 |
|
(eqt class class2) |
160 |
|
i x y z |
161 |
|
))))) |
162 |
|
(%m)) |
163 |
|
(t t 3 1 2 3)) |
164 |
|
|
165 |
|
(deftest find-class.18 |
166 |
|
(progn |
167 |
|
(setf (find-class 'find-class-class-01) nil) |
168 |
|
(let* ((class (eval '(defclass find-class-class-01 () ()))) |
169 |
|
(class1 (find-class 'find-class-class-01)) |
170 |
|
(class2 (setf (find-class 'find-class-class-01) nil)) |
171 |
|
(class3 (find-class 'find-class-class-01 nil))) |
172 |
|
(values |
173 |
|
(eqt class class1) |
174 |
|
(eqt class class2) |
175 |
|
class2 |
176 |
|
(class-name class) |
177 |
|
class3))) |
178 |
|
t nil nil find-class-class-01 nil) |
179 |
|
|
180 |
|
(deftest find-class.19 |
181 |
|
(progn |
182 |
|
(setf (find-class 'find-class-class-01 nil) nil) |
183 |
|
(setf (find-class 'find-class-class-01 t) nil) ;; should not throw error |
184 |
|
(let* ((class (eval '(defclass find-class-class-01 () ()))) |
185 |
|
(class1 (find-class 'find-class-class-01)) |
186 |
|
(class2 (setf (find-class 'find-class-class-01 t nil) |
187 |
|
class1))) |
188 |
|
(values |
189 |
|
(eqt class class1) |
190 |
|
(eqt class class2)))) |
191 |
|
t t) |
192 |
|
|
193 |
|
;; Change to a different class |
194 |
|
|
195 |
|
(deftest find-class.20 |
196 |
|
(progn |
197 |
|
(setf (find-class 'find-class-class-01) nil) |
198 |
|
(setf (find-class 'find-class-class-02) nil) |
199 |
|
(let* ((class1 (eval '(defclass find-class-class-01 () ()))) |
200 |
|
(class2 (eval '(defclass find-class-class-02 () ())))) |
201 |
|
(setf (find-class 'find-class-class-01) class2) |
202 |
|
(let* ((new-class1 (find-class 'find-class-class-01 nil)) |
203 |
|
(new-class2 (find-class 'find-class-class-02))) |
204 |
|
(values |
205 |
|
(eqt class1 class2) |
206 |
|
(eqt class2 new-class1) |
207 |
|
(eqt class2 new-class2) |
208 |
|
(class-name class2))))) |
209 |
|
nil t t find-class-class-02) |
210 |
|
|
211 |
|
(deftest find-class.21 |
212 |
|
(progn |
213 |
|
(setf (find-class 'find-class-class-01) nil) |
214 |
|
(setf (find-class 'find-class-class-02) nil) |
215 |
|
(let* ((class1 (eval '(defclass find-class-class-01 () ()))) |
216 |
|
(class2 (eval '(defclass find-class-class-02 () ())))) |
217 |
|
(psetf (find-class 'find-class-class-01) class2 |
218 |
|
(find-class 'find-class-class-02) class1) |
219 |
|
(let* ((new-class1 (find-class 'find-class-class-01 nil)) |
220 |
|
(new-class2 (find-class 'find-class-class-02))) |
221 |
|
(values |
222 |
|
(eqt class1 class2) |
223 |
|
(eqt class2 new-class1) |
224 |
|
(eqt class1 new-class2) |
225 |
|
(class-name new-class1) |
226 |
|
(class-name new-class2) |
227 |
|
)))) |
228 |
|
nil t t find-class-class-02 find-class-class-01) |
229 |
|
|
230 |
|
;;; Effect on method dispatch |
231 |
|
|
232 |
|
(deftest find-class.22 |
233 |
|
(progn |
234 |
|
(setf (find-class 'find-class-class-01) nil) |
235 |
|
(let* ((class1 (eval |
236 |
|
'(defclass find-class-class-01 () ()))) |
237 |
|
(fn (eval '(defgeneric find-class-gf-01 (x) |
238 |
|
(:method ((x find-class-class-01)) :good) |
239 |
|
(:method ((x t)) nil)))) |
240 |
|
(obj (make-instance class1))) |
241 |
|
(values |
242 |
|
(funcall fn nil) |
243 |
|
(funcall fn obj) |
244 |
|
(setf (find-class 'find-class-class-01) nil) |
245 |
|
(funcall fn nil) |
246 |
|
(funcall fn obj)))) |
247 |
|
nil :good nil nil :good) |
248 |
|
|
249 |
|
(deftest find-class.23 |
250 |
|
(progn |
251 |
|
(setf (find-class 'find-class-class-01) nil) |
252 |
|
(setf (find-class 'find-class-class-02) nil) |
253 |
|
(let* ((class1 (eval '(defclass find-class-class-01 () ()))) |
254 |
|
(class2 (eval '(defclass find-class-class-02 |
255 |
|
(find-class-class-01) ()))) |
256 |
|
(fn (eval '(defgeneric find-class-gf-02 (x) |
257 |
|
(:method ((x find-class-class-01)) 1) |
258 |
|
(:method ((x find-class-class-02)) 2) |
259 |
|
(:method ((x t)) t)))) |
260 |
|
(obj1 (make-instance class1)) |
261 |
|
(obj2 (make-instance class2))) |
262 |
|
(values |
263 |
|
(funcall fn nil) |
264 |
|
(funcall fn obj1) |
265 |
|
(funcall fn obj2) |
266 |
|
(setf (find-class 'find-class-class-01) nil) |
267 |
|
(funcall fn nil) |
268 |
|
(funcall fn obj1) |
269 |
|
(funcall fn obj2)))) |
270 |
|
t 1 2 nil t 1 2) |
271 |
|
|
272 |
|
;;; Error tests |
273 |
|
|
274 |
|
(deftest find-class.error.1 |
275 |
|
(classify-error (find-class)) |
276 |
|
program-error) |
277 |
|
|
278 |
|
(deftest find-class.error.2 |
279 |
|
(classify-error (find-class 'symbol nil nil nil)) |
280 |
|
program-error) |