source: trunk/source/tests/ansi-tests/update-instance-for-different-class.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 3.8 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon May  5 19:32:56 2003
4;;;; Contains: Tests for UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
5
6(in-package :cl-test)
7
8(defclass uifdc-class-01a () ((a :initarg :a) (b :initarg :b)))
9(defclass uifdc-class-01b () (a b))
10
11(declaim (special *uifdc-01-obj*))
12
13(defmethod update-instance-for-different-class
14  ((from-obj uifdc-class-01a)
15   (to-obj uifdc-class-01b)
16   &rest initargs &key &allow-other-keys)
17  (declare (ignore initargs))
18  (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)
22          (slot-value from-obj 'a))
23    (slot-makunbound to-obj 'b))
24  (if (slot-boundp from-obj 'b)
25    (setf (slot-value to-obj 'a)
26          (slot-value from-obj 'b))
27    (slot-makunbound to-obj 'a))
28  to-obj)
29
30(deftest update-instance-for-different-class.1
31  (let* ((obj (make-instance 'uifdc-class-01a))
32         (new-class (find-class 'uifdc-class-01b))
33         (*uifdc-01-obj* obj))
34    (values
35     (map-slot-boundp* obj '(a b))
36     (eqt obj (change-class obj new-class))
37     (typep* obj new-class)
38     (map-slot-boundp* obj '(a b))))
39  (nil nil)
40  t t
41  (nil nil))
42
43(deftest update-instance-for-different-class.2
44  (let* ((obj (make-instance 'uifdc-class-01a :a 1))
45         (new-class (find-class 'uifdc-class-01b))
46         (*uifdc-01-obj* obj))
47    (values
48     (map-slot-boundp* obj '(a b))
49     (eqt obj (change-class obj new-class))
50     (typep* obj new-class)
51     (map-slot-boundp* obj '(a b))
52     (slot-value obj 'b)))
53  (t nil)
54  t t
55  (nil t)
56  1)
57
58(deftest update-instance-for-different-class.3
59  (let* ((obj (make-instance 'uifdc-class-01a :b 1))
60         (new-class (find-class 'uifdc-class-01b))
61         (*uifdc-01-obj* obj))
62    (values
63     (map-slot-boundp* obj '(a b))
64     (eqt obj (change-class obj new-class))
65     (typep* obj new-class)
66     (map-slot-boundp* obj '(a b))
67     (slot-value obj 'a)))
68  (nil t)
69  t t
70  (t nil)
71  1)
72
73(deftest update-instance-for-different-class.4
74  (let* ((obj (make-instance 'uifdc-class-01a :a 1 :b 2))
75         (new-class (find-class 'uifdc-class-01b))
76         (*uifdc-01-obj* obj))
77    (values
78     (map-slot-boundp* obj '(a b))
79     (eqt obj (change-class obj new-class))
80     (typep* obj new-class)
81     (map-slot-boundp* obj '(a b))
82     (slot-value obj 'a)
83     (slot-value obj 'b)))
84  (t t)
85  t t
86  (t t)
87  2 1)
88
89
90;;; after method
91
92(defclass uifdc-class-02 () ((a :initform 'x :initarg :a)
93                              (b :initarg :b)))
94
95(defmethod update-instance-for-different-class :after
96  ((from-obj uifdc-class-01a)
97   (to-obj uifdc-class-02)
98   &rest initargs &key &allow-other-keys)
99  (declare (ignore initargs))
100  (setf (slot-value to-obj 'a) 100)
101  to-obj)
102
103(deftest update-instance-for-different-class.5
104  (let* ((obj (make-instance 'uifdc-class-01a))
105         (class (find-class 'uifdc-class-02)))
106    (values
107     (eqt obj (change-class obj class))
108     (map-slot-boundp* obj '(a b))
109     (slot-value obj 'a)))
110  t (t nil) 100)
111
112(deftest update-instance-for-different-class.6
113  (let* ((obj (make-instance 'uifdc-class-01a :a 1))
114         (class (find-class 'uifdc-class-02)))
115    (values
116     (eqt obj (change-class obj class))
117     (map-slot-boundp* obj '(a b))
118     (slot-value obj 'a)))
119  t (t nil) 100)
120
121(deftest update-instance-for-different-class.7
122  (let* ((obj (make-instance 'uifdc-class-01a :b 17))
123         (class (find-class 'uifdc-class-02)))
124    (values
125     (eqt obj (change-class obj class))
126     (map-slot-boundp* obj '(a b))
127     (slot-value obj 'a)
128     (slot-value obj 'b)))
129  t (t t) 100 17)
130
131(deftest update-instance-for-different-class.8
132  (let* ((obj (make-instance 'uifdc-class-01a :b 17 :a 4))
133         (class (find-class 'uifdc-class-02)))
134    (values
135     (eqt obj (change-class obj class))
136     (map-slot-boundp* obj '(a b))
137     (slot-value obj 'a)
138     (slot-value obj 'b)))
139  t (t t) 100 17)
140
141
142
143
Note: See TracBrowser for help on using the repository browser.