/[gcl]/gcl/ansi-tests/update-instance-for-different-class.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/update-instance-for-different-class.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by pfdietz, Tue May 6 01:59:43 2003 UTC revision 1.3 by pfdietz, Tue May 6 02:34:11 2003 UTC
# Line 8  Line 8 
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))
# Line 34  Line 41 
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))
# Line 77  Line 85 
85    t t    t t
86    (t t)    (t t)
87    2 1)    2 1)
   
   
   
   

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26