All Manuals > LispWorks User Guide and Reference Manual > 14 The Metaobject Protocol

NextPrevUpTopContentsIndex

14.3 Implementation of virtual slots

This is an implementation of virtual slots with readers, writers and which also allow access by slot-value .

;; ----------------------- Virtual Slots --------------------
(in-package "CL-USER")
 
;; Metaclass of objects that might contain virtual slots.
 
(defclass virtual-metaclass (standard-class)
  ()
  )
 
;; Mixin metaclass for virtual slots and methods to make them
;; appear virtual.
 
(defclass virtual-slot-definition 
          (standard-slot-definition)
  ((function :initarg :function 
             :accessor virtual-slot-definition-function))
  )
 
(defmethod slot-definition-allocation 
           ((slotd virtual-slot-definition))
  :virtual)
 
(defmethod (setf slot-definition-allocation) 
           (allocation (slotd virtual-slot-definition))
  (unless (eq allocation :virtual)
    (error "Cannot change the allocation of a ~S"
           'virtual-direct-slot-definition))
  allocation)
 
;; Class of direct virtual slots and methods to construct them
;; when appropriate.
 
(defclass virtual-direct-slot-definition 
          (standard-direct-slot-definition
           virtual-slot-definition)
  ()
  )
 
;; Called when the class is being made, to choose the metaclass of
;; a given direct slot. It should return the class of slot
;; definition required.
 
(defmethod clos:direct-slot-definition-class 
           ((class virtual-metaclass) &rest initargs)
  ;; Use virtual-direct-slot-definition if appropriate.
  (if (eq (getf initargs :allocation) :virtual)
      (find-class 'virtual-direct-slot-definition)
    (call-next-method)))
 
;; Called when the defclass is expanded, to process a slot option.
;; It should return the new list of slot options, based on
;; already-processed-options.
 
(defmethod clos:process-a-slot-option 
           ((class virtual-metaclass) option value
            already-processed-options slot)
  ;; Handle the :function option by adding it to the
  ;; list of processed options.
  (if (eq option :function)
      (list* :function value already-processed-options)
    (call-next-method)))
 
 
;; Class of effective virtual slots and methods to construct
;; them when appropriate.
 
(defclass virtual-effective-slot-definition 
          (standard-effective-slot-definition
           virtual-slot-definition)
  ()
  )
 
;; Called when the class is being finalized, to choose the
;; metaclass of a given effective slot.  It should return the
;; class of slot definition required.
 
(defmethod clos:effective-slot-definition-class 
           ((class virtual-metaclass) &rest initargs)
  ;; Use virtual-effective-slot-definition if appropriate.
  (let ((slot-initargs (getf initargs :initargs)))
    (if (member :virtual-slot slot-initargs)
        (find-class 'virtual-effective-slot-definition)
      (call-next-method))))
 
(defmethod clos:compute-effective-slot-definition 
           ((class virtual-metaclass)
            name
            direct-slot-definitions)
  ;; Copy the function into the effective slot definition
  ;; if appropriate.
  (let ((effective-slotd (call-next-method)))
    (dolist (slotd direct-slot-definitions)
      (when (typep slotd 'virtual-slot-definition)
        (setf (virtual-slot-definition-function effective-slotd) 
              (virtual-slot-definition-function slotd))
        (return)))
    effective-slotd))
 
 
;; Underlying access methods for invoking
;; virtual-slot-definition-function.
 
(defmethod clos:slot-value-using-class 
           ((class virtual-metaclass) object slot-name)
  (let ((slotd (find slot-name (class-slots class) 
                     :key 'slot-definition-name)))
    (if (typep slotd 'virtual-slot-definition)
        (funcall (virtual-slot-definition-function slotd)
                 :get
                 object)
      (call-next-method))))
 
(defmethod (setf clos:slot-value-using-class) 
           (value (class virtual-metaclass) object slot-name)
  (format t "~% setf slot : ~A" slot-name)
  (let ((slotd (find slot-name (class-slots class) 
                     :key 'slot-definition-name)))
    (if (typep slotd 'virtual-slot-definition)
        (funcall (virtual-slot-definition-function slotd)
                 :set
                 object
                 value)
      (call-next-method))))
 
(defmethod clos:slot-boundp-using-class 
           ((class virtual-metaclass) object slot-name)
  (let ((slotd (find slot-name (class-slots class) 
                     :key 'slot-definition-name)))
    (if (typep slotd 'virtual-slot-definition)
        (funcall (virtual-slot-definition-function slotd)
                 :is-set
                 object)
      (call-next-method))))
 
(defmethod clos:slot-makunbound-using-class 
           ((class virtual-metaclass) object slot-name)
  (let ((slotd (find slot-name (class-slots class) 
                     :key 'slot-definition-name)))
    (if (typep slotd 'virtual-slot-definition)
        (funcall (virtual-slot-definition-function slotd)
                 :unset
                 object)
      (call-next-method))))
 
(defmethod clos:slot-exists-p-using-class 
           ((class virtual-metaclass) object slot-name)
  (or (call-next-method)
      (and (find slot-name (class-slots class) 
                 :key 'slot-definition-name)
           t)))
 
 
;; Example virtual slot which depends on a real slot.
;; Compile this separately after the virtual-metaclass etc.
 
(defclass a-virtual-class ()
  ((real-slot :initarg :real-slot :accessor real-slot
              :initform -1)
   (virtual-slot :accessor virtual-slot 
                 :initarg :virtual-slot
                 :allocation :virtual
                 :function 
                 'a-virtual-class-virtual-slot-function))
  (:metaclass virtual-metaclass))
 
(defun a-virtual-class-virtual-slot-function 
       (key object &optional value)
  (ecase key
    (:get (let ((real-slot (real-slot object)))
            (if (<= 0 real-slot 100)
                (/ real-slot 100.0)
              (slot-unbound (class-of object) 
                            object
                            'virtual-slot))))
    (:set (setf (real-slot object) (* value 100))
          value)
    (:is-set (let ((real-slot (real-slot object)))
               (<= real-slot 100)))
    (:unset (setf (real-slot object) -1))))
;; ----------------------- Virtual Slots --------------------

Compile the code above. Then make an object and access the virtual slot:

CL-USER 1 > (setf object (make-instance 'a-virtual-class))
#<A-VIRTUAL-CLASS 2067B064>
 
CL-USER 2 > (setf (virtual-slot object) 0.75)
 
 setf slot : VIRTUAL-SLOT
0.75
 
CL-USER 3 > (virtual-slot object)
0.75
 
CL-USER 4 > (real-slot object)
75.0

Note that when you call (setf real-slot) there is no output.since (setf clos:slot-value-using-class) is not called. Compare with (setf virtual-slot).

CL-USER 5 > (setf (real-slot object) 42)
42

Redefine a-virtual-class with :optimize-slot-access nil :

CL-USER 6 > (defclass a-virtual-class ()
              ((real-slot :initarg :real-slot 
                          :accessor real-slot
                          :initform -1)
               (virtual-slot :accessor virtual-slot 
                             :initarg :virtual-slot
                             :allocation :virtual
                             :function 
                   'a-virtual-class-virtual-slot-function))
              (:metaclass virtual-metaclass)
              (:optimize-slot-access nil))
Warning: (DEFCLASS A-VIRTUAL-CLASS) being redefined in LISTENER (previously in H:\tmp\vs.lisp).
Warning: (METHOD REAL-SLOT (A-VIRTUAL-CLASS)) being redefined in LISTENER (previously in H:\tmp\vs.lisp).
Warning: (METHOD (SETF REAL-SLOT) (T A-VIRTUAL-CLASS)) being redefined in LISTENER (previously in H:\tmp\vs.lisp).
Warning: (METHOD VIRTUAL-SLOT (A-VIRTUAL-CLASS)) being redefined in LISTENER (previously in H:\tmp\vs.lisp).
Warning: (METHOD (SETF VIRTUAL-SLOT) (T A-VIRTUAL-CLASS)) being redefined in LISTENER (previously in H:\tmp\vs.lisp).
#<VIRTUAL-METACLASS A-VIRTUAL-CLASS 21AD908C>

Now the standard accessors call slot-value-using-class, so we see output when calling (setf real-slot)

CL-USER 7 > (setf (real-slot object) 42)
 
 setf slot : REAL-SLOT
42

LispWorks User Guide and Reference Manual - 21 Dec 2011

NextPrevUpTopContentsIndex