160 |
(error () :expected-error)) |
(error () :expected-error)) |
161 |
:expected-error) |
:expected-error) |
162 |
|
|
163 |
|
;; test of class name as second argument |
164 |
|
(deftest change-class.1.12 |
165 |
|
(let ((obj (make-instance 'change-class-class-01a :b 1)) |
166 |
|
(new-class (find-class 'change-class-class-01b))) |
167 |
|
(values |
168 |
|
(eqt obj (change-class obj 'change-class-class-01b :c2 3)) |
169 |
|
(typep* obj 'change-class-class-01a) |
170 |
|
(typep* obj 'change-class-class-01b) |
171 |
|
(slot-exists-p obj 'a) |
172 |
|
(map-slot-boundp* obj '(b c d)) |
173 |
|
(map-slot-value obj '(b c)))) |
174 |
|
t nil t nil (t t nil) (1 3)) |
175 |
|
|
176 |
|
|
177 |
;;; Shared slots |
;;; Shared slots |
178 |
|
|
179 |
(defclass change-class-class-02a () |
(defclass change-class-class-02a () |
306 |
(slot-value obj3 'b) |
(slot-value obj3 'b) |
307 |
)) |
)) |
308 |
(nil t) t nil t t nil (nil t) (nil t) (nil t) 17 17 17) |
(nil t) t nil t t nil (nil t) (nil t) (nil t) 17 17 17) |
309 |
|
|
310 |
|
;;; Destination class has slot initforms |
311 |
|
|
312 |
|
(defclass change-class-class-04a () |
313 |
|
((a :initarg :a) (b :initarg :b))) |
314 |
|
|
315 |
|
(defclass change-class-class-04b () |
316 |
|
((a :initform 'x :initarg :a2) |
317 |
|
(c :initform 'y :initarg :c2))) |
318 |
|
|
319 |
|
(deftest change-class.4.1 |
320 |
|
(let ((obj (make-instance 'change-class-class-04a)) |
321 |
|
(new-class (find-class 'change-class-class-04b))) |
322 |
|
(values |
323 |
|
(eqt obj (change-class obj new-class)) |
324 |
|
(map-slot-boundp* obj '(a c)) |
325 |
|
(slot-value obj 'c))) |
326 |
|
t |
327 |
|
(nil t) |
328 |
|
y) |
329 |
|
|
330 |
|
(deftest change-class.4.2 |
331 |
|
(let ((obj (make-instance 'change-class-class-04a)) |
332 |
|
(new-class (find-class 'change-class-class-04b))) |
333 |
|
(values |
334 |
|
(eqt obj (change-class obj new-class :a2 'z)) |
335 |
|
(map-slot-value obj '(a c)))) |
336 |
|
t |
337 |
|
(z y)) |
338 |
|
|
339 |
|
(deftest change-class.4.3 |
340 |
|
(let ((obj (make-instance 'change-class-class-04a :a 'p :b 'q)) |
341 |
|
(new-class (find-class 'change-class-class-04b))) |
342 |
|
(values |
343 |
|
(eqt obj (change-class obj new-class)) |
344 |
|
(map-slot-value obj '(a c)))) |
345 |
|
t |
346 |
|
(p y)) |
347 |
|
|
348 |
|
(deftest change-class.4.4 |
349 |
|
(let ((obj (make-instance 'change-class-class-04a)) |
350 |
|
(new-class (find-class 'change-class-class-04b))) |
351 |
|
(values |
352 |
|
(eqt obj (change-class obj new-class :c2 'k)) |
353 |
|
(map-slot-boundp* obj '(a c)) |
354 |
|
(slot-value obj 'c))) |
355 |
|
t |
356 |
|
(nil t) |
357 |
|
k) |
358 |
|
|
359 |
|
;;; Custom methods for change-class |
360 |
|
|
361 |
|
(declaim (special *changed-class-on-class-05*)) |
362 |
|
|
363 |
|
(defclass change-class-class-05 () |
364 |
|
(a b c)) |
365 |
|
|
366 |
|
(defmethod change-class |
367 |
|
((obj change-class-class-05) |
368 |
|
(new-class (eql (find-class 'change-class-class-05))) |
369 |
|
&rest initargs &key &allow-other-keys) |
370 |
|
(declare (ignore initargs new-class)) |
371 |
|
(setq *changed-class-on-class-05* t) |
372 |
|
obj) |
373 |
|
|
374 |
|
(deftest change-class.5 |
375 |
|
(let ((*changed-class-on-class-05* nil) |
376 |
|
(obj (make-instance 'change-class-class-05))) |
377 |
|
(values |
378 |
|
(eqt obj (change-class obj (find-class 'change-class-class-05))) |
379 |
|
*changed-class-on-class-05*)) |
380 |
|
t t) |
381 |
|
|
382 |
|
(defclass change-class-class-06 () |
383 |
|
((a :initarg :a) (b :initarg :b) (c :initarg :c))) |
384 |
|
|
385 |
|
(defmethod change-class |
386 |
|
((obj change-class-class-06) |
387 |
|
(new-class standard-class) |
388 |
|
&rest initargs &key &allow-other-keys) |
389 |
|
(declare (ignore initargs)) |
390 |
|
(setf (slot-value obj 'a) 123) |
391 |
|
(call-next-method)) |
392 |
|
|
393 |
|
(deftest change-class.6.1 |
394 |
|
(let* ((class (find-class 'change-class-class-06)) |
395 |
|
(obj (make-instance class))) |
396 |
|
(values |
397 |
|
(map-slot-boundp* obj '(a b c)) |
398 |
|
(eqt obj (change-class obj class)) |
399 |
|
(map-slot-boundp* obj '(a b c)) |
400 |
|
(slot-value obj 'a) |
401 |
|
)) |
402 |
|
(nil nil nil) |
403 |
|
t |
404 |
|
(t nil nil) |
405 |
|
123) |
406 |
|
|
407 |
|
(deftest change-class.6.2 |
408 |
|
(let* ((class (find-class 'change-class-class-06)) |
409 |
|
(obj (make-instance class :a 'bad))) |
410 |
|
(values |
411 |
|
(map-slot-boundp* obj '(a b c)) |
412 |
|
(eqt obj (change-class obj class)) |
413 |
|
(map-slot-boundp* obj '(a b c)) |
414 |
|
(slot-value obj 'a) |
415 |
|
)) |
416 |
|
(t nil nil) |
417 |
|
t |
418 |
|
(t nil nil) |
419 |
|
123) |
420 |
|
|
421 |
|
|
422 |
|
;;; Error tests |
423 |
|
|
424 |
|
(deftest change-class.error.1 |
425 |
|
(classify-error (change-class)) |
426 |
|
program-error) |
427 |
|
|
428 |
|
(deftest change-class.error.2 |
429 |
|
(classify-error |
430 |
|
(change-class (make-instance 'change-class-class-01a))) |
431 |
|
program-error) |
432 |
|
|
433 |
|
(deftest change-class.error.3 |
434 |
|
(classify-error |
435 |
|
(let ((obj (make-instance 'change-class-class-01a)) |
436 |
|
(new-class (find-class 'change-class-class-01b))) |
437 |
|
(change-class obj new-class :c2))) |
438 |
|
program-error) |
439 |
|
|
440 |
|
(deftest change-class.error.4 |
441 |
|
(classify-error |
442 |
|
(let ((obj (make-instance 'change-class-class-01a)) |
443 |
|
(new-class (find-class 'change-class-class-01b))) |
444 |
|
(change-class obj new-class '(nonsense) 'a))) |
445 |
|
program-error) |
446 |
|
|