8 |
(defclass uifdc-class-01a () ((a :initarg :a) (b :initarg :b))) |
(defclass uifdc-class-01a () ((a :initarg :a) (b :initarg :b))) |
9 |
(defclass uifdc-class-01b () (a b)) |
(defclass uifdc-class-01b () (a b)) |
10 |
|
|
11 |
|
(declaim (special *uifdc-01-obj*)) |
12 |
|
|
13 |
(defmethod update-instance-for-different-class |
(defmethod update-instance-for-different-class |
14 |
((from-obj uifdc-class-01a) |
((from-obj uifdc-class-01a) |
15 |
(to-obj uifdc-class-01b) |
(to-obj uifdc-class-01b) |
16 |
&rest initargs &key &allow-other-keys) |
&rest initargs &key &allow-other-keys) |
17 |
(declare (ignore initargs)) |
(declare (ignore initargs)) |
18 |
(when (slot-boundp from-obj 'a) |
(assert (not (eq *uifdc-01-obj* from-obj))) |
19 |
|
(assert (eq *uifdc-01-obj* to-obj)) |
20 |
|
(if (slot-boundp from-obj 'a) |
21 |
(setf (slot-value to-obj 'b) |
(setf (slot-value to-obj 'b) |
22 |
(slot-value from-obj 'a))) |
(slot-value from-obj 'a)) |
23 |
(when (slot-boundp from-obj 'b) |
(slot-makunbound to-obj 'b)) |
24 |
|
(if (slot-boundp from-obj 'b) |
25 |
(setf (slot-value to-obj 'a) |
(setf (slot-value to-obj 'a) |
26 |
(slot-value from-obj 'b))) |
(slot-value from-obj 'b)) |
27 |
|
(slot-makunbound to-obj 'a)) |
28 |
to-obj) |
to-obj) |
29 |
|
|
30 |
(deftest update-instance-for-different-class.1 |
(deftest update-instance-for-different-class.1 |
31 |
(let ((obj (make-instance 'uifdc-class-01a)) |
(let* ((obj (make-instance 'uifdc-class-01a)) |
32 |
(new-class (find-class 'uifdc-class-01b))) |
(new-class (find-class 'uifdc-class-01b)) |
33 |
|
(*uifdc-01-obj* obj)) |
34 |
(values |
(values |
35 |
(map-slot-boundp* obj '(a b)) |
(map-slot-boundp* obj '(a b)) |
36 |
(eqt obj (change-class obj new-class)) |
(eqt obj (change-class obj new-class)) |
41 |
(nil nil)) |
(nil nil)) |
42 |
|
|
43 |
(deftest update-instance-for-different-class.2 |
(deftest update-instance-for-different-class.2 |
44 |
(let ((obj (make-instance 'uifdc-class-01a :a 1)) |
(let* ((obj (make-instance 'uifdc-class-01a :a 1)) |
45 |
(new-class (find-class 'uifdc-class-01b))) |
(new-class (find-class 'uifdc-class-01b)) |
46 |
|
(*uifdc-01-obj* obj)) |
47 |
(values |
(values |
48 |
(map-slot-boundp* obj '(a b)) |
(map-slot-boundp* obj '(a b)) |
49 |
(eqt obj (change-class obj new-class)) |
(eqt obj (change-class obj new-class)) |
50 |
(typep* obj new-class) |
(typep* obj new-class) |
51 |
(map-slot-boundp* obj '(a b)) |
(map-slot-boundp* obj '(a b)) |
|
(slot-value obj 'a) |
|
52 |
(slot-value obj 'b))) |
(slot-value obj 'b))) |
53 |
(t nil) |
(t nil) |
54 |
t t |
t t |
55 |
(t t) |
(nil t) |
56 |
1 1) |
1) |
57 |
|
|
58 |
(deftest update-instance-for-different-class.3 |
(deftest update-instance-for-different-class.3 |
59 |
(let ((obj (make-instance 'uifdc-class-01a :b 1)) |
(let* ((obj (make-instance 'uifdc-class-01a :b 1)) |
60 |
(new-class (find-class 'uifdc-class-01b))) |
(new-class (find-class 'uifdc-class-01b)) |
61 |
|
(*uifdc-01-obj* obj)) |
62 |
(values |
(values |
63 |
(map-slot-boundp* obj '(a b)) |
(map-slot-boundp* obj '(a b)) |
64 |
(eqt obj (change-class obj new-class)) |
(eqt obj (change-class obj new-class)) |
65 |
(typep* obj new-class) |
(typep* obj new-class) |
66 |
(map-slot-boundp* obj '(a b)) |
(map-slot-boundp* obj '(a b)) |
67 |
(slot-value obj 'a) |
(slot-value obj 'a))) |
|
(slot-value obj 'b))) |
|
68 |
(nil t) |
(nil t) |
69 |
t t |
t t |
70 |
(t t) |
(t nil) |
71 |
1 1) |
1) |
72 |
|
|
73 |
(deftest update-instance-for-different-class.4 |
(deftest update-instance-for-different-class.4 |
74 |
(let ((obj (make-instance 'uifdc-class-01a :a 1 :b 2)) |
(let* ((obj (make-instance 'uifdc-class-01a :a 1 :b 2)) |
75 |
(new-class (find-class 'uifdc-class-01b))) |
(new-class (find-class 'uifdc-class-01b)) |
76 |
|
(*uifdc-01-obj* obj)) |
77 |
(values |
(values |
78 |
(map-slot-boundp* obj '(a b)) |
(map-slot-boundp* obj '(a b)) |
79 |
(eqt obj (change-class obj new-class)) |
(eqt obj (change-class obj new-class)) |
85 |
t t |
t t |
86 |
(t t) |
(t t) |
87 |
2 1) |
2 1) |
|
|
|
|
|
|
|
|
|
|
|
|