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 - 01 Dec 2021 19:30:21