As a MOP newbie (and CL renewbie) I'm working through some of the AMOP
exercises in CMUCL. Now, I'm stumped on exercise 3.4, where I'm supposed
to replace the standard slot allocation scheme with a dynamic one, so
that the user can say
(defclass movable-rectangle (rectangle)
((previous-height :allocation :dynamic)
(previous-width :allocation :dynamic))
(:metaclass dynamic-slot-class))
to get the two slots PREVIOUS-HEIGHT and PREVIOUS-WIDTH stored
on-demand.
However, the above defclass doesn't work in CMUCL; as I get the error
Type-error in KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER:
:DYNAMIC is not of type (MEMBER :CLASS :INSTANCE)
[Condition of type TYPE-ERROR]
which agrees with both the HyperSpec and CLtL2 in that the :allocation
slot option is either :class or :instance. (That ":allocation :dynamic"
worked in SBCL was just me being lucky, I guess.)
By introducing my own slot-definition classes and specializing
compute-effective-slot-definition I could smuggle the dynamic-ness of a
slot into allocate-instance where I could handle it. But I still
couldn't stop CLOS from giving the slot a standard location...
So: How is this supposed to be done in CMUCL?
Here is the solution that worked in SBCL. It is not too different from
the one sketched out in the AMOP solutions appendix --- so I feel it's
on the right track, at least.
;;; Exercise 3.4 from AMOP (p. 104)
#+sbcl (use-package 'sb-mop)
#+pcl (use-package 'pcl)
(defclass dynamic-slot-class (standard-class) ())
(defmethod validate-superclass ((class dynamic-slot-class)
(super standard-class))
t)
(let ((table (make-hash-table :test #'eq)))
(defun allocate-table-entry (instance)
(setf (gethash instance table) '()))
(defun display-table ()
(format t " ~s entries:~%" (hash-table-count table))
(labels ((display-entry (k v)
(format t " ~s: ~s~%" k v)))
(maphash #'display-entry table))
(values))
(defun read-dynamic-slot-value (instance slot-name)
(let* ((alist (gethash instance table))
(entry (assoc slot-name alist)))
(if (null entry)
(error "Slot ~s in ~s is unbound." slot-name instance)
(cdr entry))))
(defun write-dynamic-slot-value (new-value instance slot-name)
(let* ((alist (gethash instance table))
(entry (assoc slot-name alist)))
(if (null entry)
(push `(,slot-name . ,new-value) (gethash instance table))
(setf (cdr entry) new-value))
new-value))
(defun dynamic-slot-boundp (instance slot-name)
(let* ((alist (gethash instance table))
(entry (assoc slot-name alist)))
(not (null entry))))
(defun dynamic-slot-makunbound (instance slot-name)
(let* ((alist (gethash instance table))
(entry (assoc slot-name alist)))
(unless (null entry)
(setf (gethash instance table)
(delete entry alist))))
instance)
)
(defun dynamic-slot-p (slot)
(eq (slot-definition-allocation slot) :dynamic))
(defmethod allocate-instance ((class dynamic-slot-class)
&rest initargs)
(declare (ignore initargs))
(let ((instance (call-next-method)))
(when (some #'dynamic-slot-p (class-direct-slots class))
(allocate-table-entry instance))
instance))
(defmethod slot-boundp-using-class ((class dynamic-slot-class)
instance slot)
(format t "boundp: ~s ~s ~s~%"
instance slot (slot-definition-allocation slot))
(if (dynamic-slot-p slot)
(dynamic-slot-boundp instance (slot-definition-name slot))
(call-next-method)))
(defmethod slot-makunbound-using-class ((class dynamic-slot-class)
instance slot)
(format t "makunbound: ~s ~s ~s~%"
instance slot (slot-definition-allocation slot))
(if (dynamic-slot-p slot)
(dynamic-slot-makunbound instance (slot-definition-name slot))
(call-next-method)))
(defmethod slot-value-using-class ((class dynamic-slot-class)
instance slot)
(format t "slot-value: ~s ~s ~s~%"
instance slot (slot-definition-allocation slot))
(if (dynamic-slot-p slot)
(read-dynamic-slot-value instance (slot-definition-name slot))
(call-next-method)))
(defmethod (setf slot-value-using-class) (new-value
(class dynamic-slot-class)
instance slot)
(format t "setf slot-value: ~s ~s ~s~%"
instance slot (slot-definition-allocation slot))
(if (dynamic-slot-p slot)
(write-dynamic-slot-value new-value instance (slot-definition-name
slot))
(call-next-method)))
(defclass rectangle ()
((height :initform 0.0 :initarg :height)
(width :initform 0.0 :initarg :width)))
(defclass movable-rectangle (rectangle)
((previous-height :allocation :dynamic)
(previous-width :allocation :dynamic))
(:metaclass dynamic-slot-class))
(defclass other-rectangle (rectangle)
((colour))
(:metaclass dynamic-slot-class))
--
Sverker Wiberg <[EMAIL PROTECTED]>
