Lower :test #'= to #'eql on integer items.
[sbcl.git] / tests / mop-2.impure-cload.lisp
blobb1b3a65a8822aebabd8685fc6f1bf72b844292d9
1 ;;;; miscellaneous side-effectful tests of the MOP
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; from CMU CL.
9 ;;;;
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 ;;;; Note that the MOP is not in an entirely supported state.
15 ;;;; However, this seems a good a way as any of ensuring that we have
16 ;;;; no regressions.
18 ;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
19 ;;; fixups for running in the full MOP rather than closette -- SLOTDs
20 ;;; instead of slot-names, and so on -- and :allocation :dynamic for
21 ;;; dynamic slots.
23 (defclass dynamic-slot-class (standard-class) ())
25 (defmethod sb-mop:validate-superclass
26 ((class dynamic-slot-class) (super standard-class))
29 (defun dynamic-slot-p (slot)
30 (eq (sb-mop:slot-definition-allocation slot) :dynamic))
32 (eval-when (:compile-toplevel :load-toplevel :execute)
33 (let ((table (make-hash-table)))
35 (defun allocate-table-entry (instance)
36 (setf (gethash instance table) ()))
38 (defun read-dynamic-slot-value (instance slot-name)
39 (let* ((alist (gethash instance table))
40 (entry (assoc slot-name alist)))
41 (if (null entry)
42 (error "slot ~S unbound in ~S" slot-name instance)
43 (cdr entry))))
45 (defun write-dynamic-slot-value (new-value instance slot-name)
46 (let* ((alist (gethash instance table))
47 (entry (assoc slot-name alist)))
48 (if (null entry)
49 (push `(,slot-name . ,new-value)
50 (gethash instance table))
51 (setf (cdr entry) new-value))
52 new-value))
54 (defun dynamic-slot-names (instance)
55 (mapcar #'car (gethash instance table)))
57 (defun dynamic-slot-boundp (instance slot-name)
58 (let* ((alist (gethash instance table))
59 (entry (assoc slot-name alist)))
60 (not (null entry))))
62 (defun dynamic-slot-makunbound (instance slot-name)
63 (let* ((alist (gethash instance table))
64 (entry (assoc slot-name alist)))
65 (unless (null entry)
66 (setf (gethash instance table) (delete entry alist))))
67 instance)
71 (defmethod allocate-instance ((class dynamic-slot-class) &key)
72 (let ((instance (call-next-method)))
73 (allocate-table-entry instance)
74 instance))
76 (defmethod sb-mop:slot-value-using-class ((class dynamic-slot-class)
77 instance slotd)
78 (let ((slot (find slotd (sb-mop:class-slots class))))
79 (if (and slot (dynamic-slot-p slot))
80 (read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
81 (call-next-method))))
83 (defmethod (setf sb-mop:slot-value-using-class) (new-value (class dynamic-slot-class)
84 instance slotd)
85 (let ((slot (find slotd (sb-mop:class-slots class))))
86 (if (and slot (dynamic-slot-p slot))
87 (write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
88 (call-next-method))))
90 (defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-class)
91 instance slotd)
92 (let ((slot (find slotd (sb-mop:class-slots class))))
93 (if (and slot (dynamic-slot-p slot))
94 (dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
95 (call-next-method))))
97 (defmethod sb-mop:slot-makunbound-using-class ((class dynamic-slot-class)
98 instance slotd)
99 (let ((slot (find slotd (sb-mop:class-slots class))))
100 (if (and slot (dynamic-slot-p slot))
101 (dynamic-slot-makunbound instance (sb-mop:slot-definition-name slotd))
102 (call-next-method))))
104 (defclass test-class-1 ()
105 ((slot1 :initarg :slot1 :allocation :dynamic)
106 (slot2 :initarg :slot2 :initform nil))
107 (:metaclass dynamic-slot-class))
109 (defclass test-class-2 (test-class-1)
110 ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
111 (slot3 :initarg :slot3))
112 (:metaclass dynamic-slot-class))
114 (defvar *one* (make-instance 'test-class-1))
115 (defvar *two* (make-instance 'test-class-2 :slot3 1))
117 (with-test (:name (:mop-2 1))
118 (assert (not (slot-boundp *one* 'slot1)))
119 (assert (null (slot-value *one* 'slot2)))
120 (assert (eq t (slot-value *two* 'slot2)))
121 (assert (= 1 (slot-value *two* 'slot3))))
123 ;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
124 ;;; overconservatism in accessing a class's precedence list deep in
125 ;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of
126 ;;; finalizing a class.
127 (defclass dynamic-slot-subclass (dynamic-slot-class) ())
129 (defmethod sb-mop:slot-value-using-class ((class dynamic-slot-subclass)
130 instance slotd)
131 (let ((slot (find slotd (sb-mop:class-slots class))))
132 (if (and slot (dynamic-slot-p slot))
133 (read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
134 (call-next-method))))
136 (defmethod (setf sb-mop:slot-value-using-class) (new-value
137 (class dynamic-slot-subclass)
138 instance slotd)
139 (let ((slot (find slotd (sb-mop:class-slots class))))
140 (if (and slot (dynamic-slot-p slot))
141 (write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
142 (call-next-method))))
144 (defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-subclass)
145 instance slotd)
146 (let ((slot (find slotd (sb-mop:class-slots class))))
147 (if (and slot (dynamic-slot-p slot))
148 (dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
149 (call-next-method))))
151 (defclass test-class-3 (test-class-1)
152 ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
153 (slot3 :initarg :slot3))
154 (:metaclass dynamic-slot-subclass))
156 (defvar *three* (make-instance 'test-class-3 :slot3 3))
158 (with-test (:name (:mop-2 2))
159 (assert (not (slot-boundp *three* 'slot1)))
160 (assert (eq (slot-value *three* 'slot2) t))
161 (assert (= (slot-value *three* 'slot3) 3)))
163 (defmethod slot-missing ((class dynamic-slot-class) instance slot-name operation &optional v)
164 (declare (ignore v))
165 (list :slot-missing slot-name))
167 ;;; Test redefinition adding a dynamic slot
168 (defclass test-class-3 (test-class-1)
169 ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
170 (slot3 :initarg :slot3)
171 (slot4 :initarg :slot4 :initform 42 :allocation :dynamic))
172 (:metaclass dynamic-slot-subclass))
174 (with-test (:name (:mop-2 3))
175 (assert (= 42 (slot-value *three* 'slot4))))
177 (with-test (:name (:mop-2 :slot-exists-p-before-removal))
178 (let ((i (make-instance 'test-class-3)))
179 (dolist (s '(slot1 slot2 slot3 slot4)) (assert (slot-exists-p i s)))))
181 ;;; Test redefinition removing a dynamic slot
182 (defclass test-class-3 (test-class-1)
183 ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
184 (slot3 :initarg :slot3))
185 (:metaclass dynamic-slot-subclass))
187 (with-test (:name (:mop-2 4))
188 (assert (equal (list :slot-missing 'slot4) (slot-value *three* 'slot4))))
190 (with-test (:name (:mop-2 :slot-exists-p-after-removal))
191 (let ((i (make-instance 'test-class-3)))
192 (assert (not (slot-exists-p i 'slot4)))
193 (dolist (s '(slot1 slot2 slot3)) (assert (slot-exists-p i s)))))
195 ;;; Test redefinition making a dynamic slot local
197 ;;; NOTE: seriously underspecified. We muddle somehow.
198 (defclass test-class-3 (test-class-1)
199 ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
200 (slot3 :initarg :slot3))
201 (:metaclass dynamic-slot-subclass))
203 (with-test (:name (:mop-2 5))
204 (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
205 (slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
206 (assert (eq :instance (sb-mop:slot-definition-allocation slot)))
207 (assert (eq 'ok (slot-value *three* 'slot2)))))
209 ;;; Test redefinition making a local slot dynamic again
211 ;;; NOTE: seriously underspecified. We muddle somehow.
212 ;;; This picks up the old value from the table, not the
213 ;;; new initform.
214 (defclass test-class-3 (test-class-1)
215 ((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic)
216 (slot3 :initarg :slot3))
217 (:metaclass dynamic-slot-subclass))
219 (with-test (:name (:mop-2 6))
220 (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
221 (slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
222 (assert (eq :dynamic (sb-mop:slot-definition-allocation slot)))
223 (assert (eq t (slot-value *three* 'slot2)))))
225 ;;; Test redefinition making a dynamic slot local, with
226 ;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot.
227 ;;; Then we make it dynamic again.
229 ;;; NOTE: seriously underspecified. We muddle somehow.
230 (defmethod update-instance-for-redefined-class :after ((obj test-class-3) add drop plist
231 &rest inits)
232 (declare (ignore inits))
233 (let* ((class (class-of obj))
234 (slots (sb-mop:class-slots class)))
235 (dolist (name (dynamic-slot-names obj))
236 (let ((slotd (find name slots :key #'sb-mop:slot-definition-name)))
237 (unless (and slotd (eq :dynamic (sb-mop:slot-definition-allocation slotd)))
238 (dynamic-slot-makunbound obj name))))))
240 (defclass test-class-3 (test-class-1)
241 ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
242 (slot3 :initarg :slot3))
243 (:metaclass dynamic-slot-subclass))
245 (with-test (:name (:mop-2 7))
246 (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
247 (slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
248 (assert (eq :instance (sb-mop:slot-definition-allocation slot)))
249 (assert (eq 'ok (slot-value *three* 'slot2)))))
251 (defclass test-class-3 (test-class-1)
252 ((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic)
253 (slot3 :initarg :slot3))
254 (:metaclass dynamic-slot-subclass))
256 (with-test (:name (:mop-2 8))
257 (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
258 (slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
259 (assert (eq :dynamic (sb-mop:slot-definition-allocation slot)))
260 (assert (eq 'ok! (slot-value *three* 'slot2)))))
262 (defclass makunbound-test-class (standard-class) ())
264 (defmethod sb-mop:validate-superclass ((class makunbound-test-class) (superclass standard-class))
267 (defmethod sb-mop:slot-makunbound-using-class ((class makunbound-test-class) object slotd)
268 (throw 'slot-makunbound-using-class t))
270 (defclass test-class ()
271 ((slot :initarg :slot))
272 (:metaclass makunbound-test-class))
274 (with-test (:name :slot-makunbound-using-class)
275 (assert (catch 'slot-makunbound-using-class
276 (slot-makunbound (make-instance 'test-class) 'slot)
277 nil)))