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.
22 (defclass dynamic-slot-class
(standard-class) ())
24 (defmethod sb-mop:validate-superclass
25 ((class dynamic-slot-class
) (super standard-class
))
28 (defmethod sb-mop:compute-effective-slot-definition
29 ((class dynamic-slot-class
) name direct-slots
)
30 (let ((slot (call-next-method)))
31 (setf (sb-mop:slot-definition-allocation slot
) :dynamic
)
34 (defun dynamic-slot-p (slot)
35 (eq (sb-mop:slot-definition-allocation slot
) :dynamic
))
37 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
39 (let ((table (make-hash-table)))
41 (defun allocate-table-entry (instance)
42 (setf (gethash instance table
) ()))
44 (defun read-dynamic-slot-value (instance slot-name
)
45 (let* ((alist (gethash instance table
))
46 (entry (assoc slot-name alist
)))
48 (error "slot ~S unbound in ~S" slot-name instance
)
51 (defun write-dynamic-slot-value (new-value instance slot-name
)
52 (let* ((alist (gethash instance table
))
53 (entry (assoc slot-name alist
)))
55 (push `(,slot-name .
,new-value
)
56 (gethash instance table
))
57 (setf (cdr entry
) new-value
))
60 (defun dynamic-slot-boundp (instance slot-name
)
61 (let* ((alist (gethash instance table
))
62 (entry (assoc slot-name alist
)))
65 (defun dynamic-slot-makunbound (instance slot-name
)
66 (let* ((alist (gethash instance table
))
67 (entry (assoc slot-name alist
)))
69 (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 sb-mop:slot-value-using-class
((class dynamic-slot-class
)
81 (let ((slot (find slotd
(sb-mop:class-slots class
))))
83 (read-dynamic-slot-value instance
(sb-mop:slot-definition-name slotd
))
86 (defmethod (setf sb-mop
:slot-value-using-class
) (new-value (class dynamic-slot-class
)
88 (let ((slot (find slotd
(sb-mop:class-slots class
))))
90 (write-dynamic-slot-value new-value instance
(sb-mop:slot-definition-name slotd
))
93 (defmethod sb-mop:slot-boundp-using-class
((class dynamic-slot-class
)
95 (let ((slot (find slotd
(sb-mop:class-slots class
))))
97 (dynamic-slot-boundp instance
(sb-mop:slot-definition-name slotd
))
100 (defmethod sb-mop:slot-makunbound-using-class
((class dynamic-slot-class
)
102 (let ((slot (find slotd
(sb-mop:class-slots class
))))
104 (dynamic-slot-makunbound instance
(sb-mop:slot-definition-name slotd
))
105 (call-next-method))))
107 (defclass test-class-1
()
108 ((slot1 :initarg
:slot1
)
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
)
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 (with-test (:name
:mop-1
)
121 (assert (not (slot-boundp *one
* 'slot1
)))
122 (assert (null (slot-value *one
* 'slot2
)))
123 (assert (eq t
(slot-value *two
* 'slot2
)))
124 (assert (= 1 (slot-value *two
* 'slot3
))))