The standard idiom for class initialization / reinitialization when you want to add your own default topmost object (like standard-object and funcallable-standard-object for standard-class and funcallable-standard-class) is the one below.
(defmethod initialize-instance :around
((class my-class) &rest initargs
&key direct-superclasses)
(declare (dynamic-extent initargs))
(if (loop for class in direct-superclasses
thereis (subtypep class (find-class 'my-object)))
;; 'my-object is already one of the (indirect) superclasses
(call-next-method)
;; 'my-object is not one of the superclasses, so we have to add it
(apply #'call-next-method
class
:direct-superclasses
(append direct-superclasses
(list (find-class 'my-object)))
initargs)))
(defmethod reinitialize-instance :around
((class my-class) &rest initargs
&key (direct-superclasses '() direct-superclasses-p))
(declare (dynamic-extent initargs))
(if direct-superclasses-p
;; if direct superclasses are explicitly passed
;; this is exactly like above
(if (loop for class in direct-superclasses
thereis (subtypep class (find-class 'my-object)))
(call-next-method)
(apply #'call-next-method
class
:direct-superclasses
(append direct-superclasses
(list (find-class 'my-object)))
initargs))
;; if direct superclasses are not explicitly passed
;; we _must_ not change anything
(call-next-method)))
The idea is to use standard-instance-access and capture the slot-definition-location into the accessor lambda, so we have an accessor with only 'eq comparisons and standard-instance-access calls.
Issues that needs to be dealth with:
For a working example and the original source of the code scratch below take a look at computed-class
(defclass computed-slot-definition (standard-slot-definition)
((computed-readers
:initform nil
:type list
:accessor computed-readers-of
:initarg :computed-readers)
(computed-writers
:initform nil
:type list
:accessor computed-writers-of
:initarg :computed-writers)))
(defclass computed-direct-slot-definition (computed-slot-definition standard-direct-slot-definition)
())
(defclass computed-direct-slot-definition-with-custom-accessors (computed-direct-slot-definition)
()
(:documentation "This direct slot definition converts the :readers and :writers initargs to :computed-readers and :computed-writers effectively disabling the generation of default accessors."))
(defclass computed-effective-slot-definition (computed-slot-definition standard-effective-slot-definition)
())
(defmethod initialize-instance :around ((slot computed-direct-slot-definition-with-custom-accessors)
&rest args &key readers writers &allow-other-keys)
(remf-keywords args :readers :writers)
(apply #'call-next-method slot :computed-readers readers :computed-writers writers args))
(defmethod compute-effective-slot-definition :around ((class computed-class) name direct-slot-definitions)
(declare (type list direct-slot-definitions))
(let ((%computed-effective-slot-definition% (find-if (lambda (direct-slot-definition)
(typep direct-slot-definition 'computed-direct-slot-definition))
direct-slot-definitions)))
(declare (special %computed-effective-slot-definition%))
(aprog1
(call-next-method)
;; We collect and copy the readers and writers to the effective-slot, so we can access it
;; later when generating custom accessors.
(when (typep it 'computed-effective-slot-definition)
(setf (computed-readers-of it)
(remove-duplicates (loop for direct-slot-definition :in direct-slot-definitions
appending (if (typep direct-slot-definition 'computed-direct-slot-definition)
(computed-readers-of direct-slot-definition)
(slot-definition-readers direct-slot-definition)))
:test #'equal))
(setf (computed-writers-of it)
(remove-duplicates (loop for direct-slot-definition :in direct-slot-definitions
appending (if (typep direct-slot-definition 'computed-direct-slot-definition)
(computed-writers-of direct-slot-definition)
(slot-definition-writers direct-slot-definition)))
:test #'equal))))))
(defmethod slot-value-using-class ((class computed-class)
(object computed-object)
(slot computed-effective-slot-definition))
(declare #.(optimize-declaration))
#.(slot-value-using-class-body))
(defmethod (setf slot-value-using-class) (new-value
(class computed-class)
(object computed-object)
(slot computed-effective-slot-definition))
(declare #.(optimize-declaration))
#.(setf-slot-value-using-class-body))
(defmethod slot-boundp-using-class ((class computed-class)
(object computed-object)
(slot computed-effective-slot-definition))
(declare #.(optimize-declaration))
(not (eq #.(standard-instance-access-form)
'#.+unbound-slot-value+)))
(defmethod slot-makunbound-using-class ((class computed-class)
(object computed-object)
(slot computed-effective-slot-definition))
(declare #.(optimize-declaration))
#.(setf-standard-instance-access-form nil (quote (quote #.+unbound-slot-value+))))
(defun ensure-accessor-for (class accessor-name effective-slot type)
(let* ((gf (ensure-generic-function accessor-name :lambda-list (ecase type
(:reader '(object))
(:writer '(new-value object)))))
(specializers (ecase type
(:reader (list class))
(:writer (list (find-class 't) class))))
(current-method (find-method gf '() specializers #f)))
(if (and current-method
(typep current-method 'computed-accessor-method)
(= (slot-definition-location (effective-slot-of current-method))
(slot-definition-location effective-slot)))
(progn
(log.dribble "Keeping compatible ~A for class ~A, slot ~S, slot-location ~A"
(string-downcase (symbol-name type)) class (slot-definition-name effective-slot)
(slot-definition-location effective-slot))
(setf (effective-slot-of current-method) effective-slot))
(progn
(log.debug "Ensuring new ~A for class ~A, slot ~S, effective-slot ~A, slot-location ~A"
(string-downcase (symbol-name type)) class (slot-definition-name effective-slot)
effective-slot (slot-definition-location effective-slot))
(let ((method (ensure-method gf
(ecase type
(:reader
`(lambda (object)
(declare (optimize (speed 1))) ; (speed 1) to ignore compiler notes when defining accessors
(log.dribble "Entered reader for object ~A, generated for class ~A, slot ~A, slot-location ~A"
object ,class ,effective-slot ,(slot-definition-location effective-slot))
(if (eq (class-of object) ,class)
(progn
,(slot-value-using-class-body effective-slot))
(progn
(log.dribble "Falling back to slot-value in reader for object ~A, slot ~A"
object (slot-definition-name ,effective-slot))
(slot-value object ',(slot-definition-name effective-slot))))))
(:writer
`(lambda (new-value object)
(declare (optimize (speed 1))) ; (speed 1) to ignore compiler notes when defining accessors
(log.dribble "Entered writer for object ~A, generated for class ~A, slot ~A, slot-location ~A"
object ,class ,effective-slot ,(slot-definition-location effective-slot))
(if (eq (class-of object) ,class)
(progn
,(setf-slot-value-using-class-body effective-slot))
(progn
(log.dribble "Falling back to (setf slot-value) in writer for object ~A, slot ~A"
object (slot-definition-name ,effective-slot))
(setf (slot-value object ',(slot-definition-name effective-slot)) new-value))))))
:specializers specializers
#+ensure-method-supports-method-class :method-class
#+ensure-method-supports-method-class (find-class 'computed-reader-method))))
(declare (ignorable method))
#+ensure-method-supports-method-class
(setf (effective-slot-of method) effective-slot))))))
(defun ensure-accessors-for (class)
(loop for effective-slot :in (class-slots class)
when (typep effective-slot 'computed-effective-slot-definition) do
(log.dribble "Visiting effective-slot ~A of class ~A to generate accessors" effective-slot class)
(dolist (reader (computed-readers-of effective-slot))
(ensure-accessor-for class reader effective-slot :reader))
(dolist (writer (computed-writers-of effective-slot))
(ensure-accessor-for class writer effective-slot :writer))))
(defmethod finalize-inheritance :after ((class computed-class*))
(ensure-accessors-for class))
This page is linked from: MOP
CLiki pages can be edited by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively