357 |
(nil t) |
(nil t) |
358 |
k) |
k) |
359 |
|
|
360 |
|
(deftest change-class.4.5 |
361 |
|
(let* ((class (find-class 'change-class-class-04b)) |
362 |
|
(obj (allocate-instance class))) |
363 |
|
(values |
364 |
|
(map-slot-boundp* obj '(a c)) |
365 |
|
(eqt obj (change-class obj class)) |
366 |
|
(map-slot-boundp* obj '(a c)))) |
367 |
|
(nil nil) |
368 |
|
t |
369 |
|
(nil nil)) |
370 |
|
|
371 |
|
|
372 |
;;; Custom methods for change-class |
;;; Custom methods for change-class |
373 |
|
|
374 |
(declaim (special *changed-class-on-class-05*)) |
(declaim (special *changed-class-on-class-05*)) |
392 |
*changed-class-on-class-05*)) |
*changed-class-on-class-05*)) |
393 |
t t) |
t t) |
394 |
|
|
395 |
|
;;; Method that invokes the standard method with call-next-method |
396 |
|
|
397 |
(defclass change-class-class-06 () |
(defclass change-class-class-06 () |
398 |
((a :initarg :a) (b :initarg :b) (c :initarg :c))) |
((a :initarg :a) (b :initarg :b) (c :initarg :c))) |
399 |
|
|
433 |
(t nil nil) |
(t nil nil) |
434 |
123) |
123) |
435 |
|
|
436 |
|
;;; Before method |
437 |
|
|
438 |
|
(defclass change-class-class-07 () |
439 |
|
((a :initform 'x :initarg :a) |
440 |
|
(b :initform 'y :initarg :b) |
441 |
|
(c :initarg :c))) |
442 |
|
|
443 |
|
(defclass change-class-class-07b () |
444 |
|
((a :initform 'aa :initarg :a) |
445 |
|
(d :initform 'dd :initarg :d))) |
446 |
|
|
447 |
|
(defmethod change-class :before |
448 |
|
((obj change-class-class-07) |
449 |
|
(new-class standard-class) |
450 |
|
&rest initargs &key &allow-other-keys) |
451 |
|
(declare (ignore initargs)) |
452 |
|
(setf (slot-value obj 'a) 'z) |
453 |
|
obj) |
454 |
|
|
455 |
|
(deftest change-class.7.1 |
456 |
|
(let* ((class (find-class 'change-class-class-07)) |
457 |
|
(obj (allocate-instance class))) |
458 |
|
(values |
459 |
|
(map-slot-boundp* obj '(a b c)) |
460 |
|
(eqt obj (change-class obj class)) |
461 |
|
(map-slot-boundp* obj '(a b c)) |
462 |
|
(slot-value obj 'a))) |
463 |
|
(nil nil nil) |
464 |
|
t |
465 |
|
(t nil nil) |
466 |
|
z) |
467 |
|
|
468 |
|
(deftest change-class.7.2 |
469 |
|
(let* ((class (find-class 'change-class-class-07)) |
470 |
|
(obj (allocate-instance class))) |
471 |
|
(values |
472 |
|
(map-slot-boundp* obj '(a b c)) |
473 |
|
(eqt obj (change-class obj class :a 10)) |
474 |
|
(map-slot-boundp* obj '(a b c)) |
475 |
|
(slot-value obj 'a))) |
476 |
|
(nil nil nil) |
477 |
|
t |
478 |
|
(t nil nil) |
479 |
|
10) |
480 |
|
|
481 |
|
(deftest change-class.7.3 |
482 |
|
(let* ((class (find-class 'change-class-class-07)) |
483 |
|
(obj (allocate-instance class))) |
484 |
|
(values |
485 |
|
(map-slot-boundp* obj '(a b c)) |
486 |
|
(eqt obj (change-class obj class :b 10)) |
487 |
|
(map-slot-boundp* obj '(a b c)) |
488 |
|
(slot-value obj 'a) |
489 |
|
(slot-value obj 'b))) |
490 |
|
(nil nil nil) |
491 |
|
t |
492 |
|
(t t nil) |
493 |
|
z 10) |
494 |
|
|
495 |
|
(deftest change-class.7.4 |
496 |
|
(let* ((class (find-class 'change-class-class-07)) |
497 |
|
(new-class (find-class 'change-class-class-07b)) |
498 |
|
(obj (allocate-instance class))) |
499 |
|
(values |
500 |
|
(eqt obj (change-class obj new-class)) |
501 |
|
(map-slot-boundp* obj '(a d)) |
502 |
|
(slot-value obj 'a) |
503 |
|
(slot-value obj 'd))) |
504 |
|
t (t t) z dd) |
505 |
|
|
506 |
|
(deftest change-class.7.5 |
507 |
|
(let* ((class (find-class 'change-class-class-07)) |
508 |
|
(new-class (find-class 'change-class-class-07b)) |
509 |
|
(obj (allocate-instance class))) |
510 |
|
(values |
511 |
|
(eqt obj (change-class obj new-class :allow-other-keys nil)) |
512 |
|
(map-slot-boundp* obj '(a d)) |
513 |
|
(slot-value obj 'a) |
514 |
|
(slot-value obj 'd))) |
515 |
|
t (t t) z dd) |
516 |
|
|
517 |
|
(deftest change-class.7.6 |
518 |
|
(let* ((class (find-class 'change-class-class-07)) |
519 |
|
(new-class (find-class 'change-class-class-07b)) |
520 |
|
(obj (allocate-instance class))) |
521 |
|
(values |
522 |
|
(eqt obj (change-class obj new-class :allow-other-keys t)) |
523 |
|
(map-slot-boundp* obj '(a d)) |
524 |
|
(slot-value obj 'a) |
525 |
|
(slot-value obj 'd))) |
526 |
|
t (t t) z dd) |
527 |
|
|
528 |
|
|
529 |
|
;;; After method |
530 |
|
|
531 |
|
(defclass change-class-class-08 () ((a :initarg :a) (b :initarg :b))) |
532 |
|
|
533 |
|
(defmethod change-class :after |
534 |
|
((obj standard-object) |
535 |
|
(class (eql (find-class 'change-class-class-08))) |
536 |
|
&rest initargs &key &allow-other-keys) |
537 |
|
(declare (ignore initargs)) |
538 |
|
(setf (slot-value obj 'a) 'z) |
539 |
|
obj) |
540 |
|
|
541 |
|
(deftest change-class.8.1 |
542 |
|
(let* ((class (find-class 'change-class-class-08)) |
543 |
|
(obj (make-instance class))) |
544 |
|
(values |
545 |
|
(map-slot-boundp* obj '(a b)) |
546 |
|
(eqt obj (change-class obj class)) |
547 |
|
(map-slot-boundp* obj '(a b)) |
548 |
|
(slot-value obj 'a))) |
549 |
|
(nil nil) |
550 |
|
t |
551 |
|
(t nil) |
552 |
|
z) |
553 |
|
|
554 |
|
(deftest change-class.8.2 |
555 |
|
(let* ((class (find-class 'change-class-class-08)) |
556 |
|
(obj (make-instance class :a 1 :b 2))) |
557 |
|
(values |
558 |
|
(map-slot-boundp* obj '(a b)) |
559 |
|
(eqt obj (change-class obj class)) |
560 |
|
(map-slot-boundp* obj '(a b)) |
561 |
|
(slot-value obj 'a) |
562 |
|
(slot-value obj 'b))) |
563 |
|
(t t) |
564 |
|
t |
565 |
|
(t t) |
566 |
|
z 2) |
567 |
|
|
568 |
|
(deftest change-class.8.3 |
569 |
|
(let* ((class (find-class 'change-class-class-08)) |
570 |
|
(obj (make-instance class))) |
571 |
|
(values |
572 |
|
(map-slot-boundp* obj '(a b)) |
573 |
|
(eqt obj (change-class obj class :a 12 :b 17)) |
574 |
|
(map-slot-boundp* obj '(a b)) |
575 |
|
(slot-value obj 'a) |
576 |
|
(slot-value obj 'b))) |
577 |
|
(nil nil) |
578 |
|
t |
579 |
|
(t t) |
580 |
|
z 17) |
581 |
|
|
582 |
|
;;; Put around method test here |
583 |
|
|
584 |
|
;;; Put more inheritance tests here |
585 |
|
|
586 |
;;; Error tests |
;;; Error tests |
587 |
|
|
588 |
(deftest change-class.error.1 |
(deftest change-class.error.1 |