1 ;;;; miscellaneous side-effectful tests of the MOP
3 ;;;; This software is part of the SBCL system. See the README file for
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
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
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
25 (defpackage "TEST" (:use "CL" "SB-MOP"))
28 (defclass dynamic-slot-class (standard-class) ())
30 (defmethod validate-superclass
31 ((class dynamic-slot-class) (super standard-class))
34 (defun dynamic-slot-p (slot)
35 (eq (slot-definition-allocation slot) :dynamic))
37 (let ((table (make-hash-table)))
39 (defun allocate-table-entry (instance)
40 (setf (gethash instance table) ()))
42 (defun read-dynamic-slot-value (instance slot-name)
43 (let* ((alist (gethash instance table))
44 (entry (assoc slot-name alist)))
46 (error "slot ~S unbound in ~S" slot-name instance)
49 (defun write-dynamic-slot-value (new-value instance slot-name)
50 (let* ((alist (gethash instance table))
51 (entry (assoc slot-name alist)))
53 (push `(,slot-name . ,new-value)
54 (gethash instance table))
55 (setf (cdr entry) new-value))
58 (defun dynamic-slot-names (instance)
59 (mapcar #'car (gethash instance table)))
61 (defun dynamic-slot-boundp (instance slot-name)
62 (let* ((alist (gethash instance table))
63 (entry (assoc slot-name alist)))
66 (defun dynamic-slot-makunbound (instance slot-name)
67 (let* ((alist (gethash instance table))
68 (entry (assoc slot-name alist)))
70 (setf (gethash instance table) (delete entry alist))))
74 (defmethod allocate-instance ((class dynamic-slot-class) &key)
75 (let ((instance (call-next-method)))
76 (allocate-table-entry instance)
79 (defmethod slot-value-using-class ((class dynamic-slot-class)
81 (let ((slot (find slotd (class-slots class))))
82 (if (and slot (dynamic-slot-p slot))
83 (read-dynamic-slot-value instance (slot-definition-name slotd))
86 (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
88 (let ((slot (find slotd (class-slots class))))
89 (if (and slot (dynamic-slot-p slot))
90 (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
93 (defmethod slot-boundp-using-class ((class dynamic-slot-class)
95 (let ((slot (find slotd (class-slots class))))
96 (if (and slot (dynamic-slot-p slot))
97 (dynamic-slot-boundp instance (slot-definition-name slotd))
100 (defmethod slot-makunbound-using-class ((class dynamic-slot-class)
102 (let ((slot (find slotd (class-slots class))))
103 (if (and slot (dynamic-slot-p slot))
104 (dynamic-slot-makunbound instance (slot-definition-name slotd))
105 (call-next-method))))
107 (defclass test-class-1 ()
108 ((slot1 :initarg :slot1 :allocation :dynamic)
109 (slot2 :initarg :slot2 :initform nil))
110 (:metaclass dynamic-slot-class))
112 (defclass test-class-2 (test-class-1)
113 ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
114 (slot3 :initarg :slot3))
115 (:metaclass dynamic-slot-class))
117 (defvar *one* (make-instance 'test-class-1))
118 (defvar *two* (make-instance 'test-class-2 :slot3 1))
120 (assert (not (slot-boundp *one* 'slot1)))
121 (assert (null (slot-value *one* 'slot2)))
122 (assert (eq t (slot-value *two* 'slot2)))
123 (assert (= 1 (slot-value *two* 'slot3)))
125 ;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
126 ;;; overconservatism in accessing a class's precedence list deep in
127 ;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of
128 ;;; finalizing a class.
129 (defclass dynamic-slot-subclass (dynamic-slot-class) ())
131 (defmethod slot-value-using-class ((class dynamic-slot-subclass)
133 (let ((slot (find slotd (class-slots class))))
134 (if (and slot (dynamic-slot-p slot))
135 (read-dynamic-slot-value instance (slot-definition-name slotd))
136 (call-next-method))))
138 (defmethod (setf slot-value-using-class) (new-value
139 (class dynamic-slot-subclass)
141 (let ((slot (find slotd (class-slots class))))
142 (if (and slot (dynamic-slot-p slot))
143 (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
144 (call-next-method))))
146 (defmethod slot-boundp-using-class ((class dynamic-slot-subclass)
148 (let ((slot (find slotd (class-slots class))))
149 (if (and slot (dynamic-slot-p slot))
150 (dynamic-slot-boundp instance (slot-definition-name slotd))
151 (call-next-method))))
153 (defclass test-class-3 (test-class-1)
154 ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
155 (slot3 :initarg :slot3))
156 (:metaclass dynamic-slot-subclass))
158 (defvar *three* (make-instance 'test-class-3 :slot3 3))
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)
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))
173 (assert (= 42 (slot-value *three* 'slot4)))
175 ;;; Test redefinition removing a dynamic slot
176 (defclass test-class-3 (test-class-1)
177 ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
178 (slot3 :initarg :slot3))
179 (:metaclass dynamic-slot-subclass))
180 (assert (equal (list :slot-missing 'slot4) (slot-value *three* 'slot4)))
182 ;;; Test redefinition making a dynamic slot local
184 ;;; NOTE: seriously underspecified. We muddle somehow.
185 (defclass test-class-3 (test-class-1)
186 ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
187 (slot3 :initarg :slot3))
188 (:metaclass dynamic-slot-subclass))
189 (let* ((slots (class-slots (find-class 'test-class-3)))
190 (slot (find 'slot2 slots :key #'slot-definition-name)))
191 (assert (eq :instance (slot-definition-allocation slot)))
192 (assert (eq 'ok (slot-value *three* 'slot2))))
194 ;;; Test redefinition making a local slot dynamic again
196 ;;; NOTE: seriously underspecified. We muddle somehow.
197 ;;; This picks up the old value from the table, not the
199 (defclass test-class-3 (test-class-1)
200 ((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic)
201 (slot3 :initarg :slot3))
202 (:metaclass dynamic-slot-subclass))
203 (let* ((slots (class-slots (find-class 'test-class-3)))
204 (slot (find 'slot2 slots :key #'slot-definition-name)))
205 (assert (eq :dynamic (slot-definition-allocation slot)))
206 (assert (eq t (slot-value *three* 'slot2))))
208 ;;; Test redefinition making a dynamic slot local, with
209 ;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot.
210 ;;; Then we make it dynamic again.
212 ;;; NOTE: seriously underspecified. We muddle somehow.
213 (defmethod update-instance-for-redefined-class :after ((obj test-class-3) add drop plist
215 (declare (ignore inits))
216 (let* ((class (class-of obj))
217 (slots (class-slots class)))
218 (dolist (name (dynamic-slot-names obj))
219 (let ((slotd (find name slots :key #'slot-definition-name)))
220 (unless (and slotd (eq :dynamic (slot-definition-allocation slotd)))
221 (dynamic-slot-makunbound obj name))))))
222 (defclass test-class-3 (test-class-1)
223 ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
224 (slot3 :initarg :slot3))
225 (:metaclass dynamic-slot-subclass))
226 (let* ((slots (class-slots (find-class 'test-class-3)))
227 (slot (find 'slot2 slots :key #'slot-definition-name)))
228 (assert (eq :instance (slot-definition-allocation slot)))
229 (assert (eq 'ok (slot-value *three* 'slot2))))
230 (defclass test-class-3 (test-class-1)
231 ((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic)
232 (slot3 :initarg :slot3))
233 (:metaclass dynamic-slot-subclass))
234 (let* ((slots (class-slots (find-class 'test-class-3)))
235 (slot (find 'slot2 slots :key #'slot-definition-name)))
236 (assert (eq :dynamic (slot-definition-allocation slot)))
237 (assert (eq 'ok! (slot-value *three* 'slot2))))