How to add your own default class for metaclass instances by Pascal Costanza
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.
[Jean-Philippe Paradis remarks: see object-class.]
(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)))
How to generate fast accessors for customized slot-value-using-class implementations by Attila Lendvai
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:
- Such an accessor is only usable for the concrete class it was generated for (because the effective slot locations are varying for each subclass) but the generic method is called also for subclasses of that class. Therefore we generate an accessor for each subclass, but this chain can be broken if the class of a subclass is not type of our metaclass. For graceful fallback we eq check (class-of instance) in the accessor lambda to the class that we used to generate this accessor for and if it's not 'eq then we fall back to a slow but correct slot-value call.
- The standard is vague around standard-instance-access and slot boundp checking is quite platform dependent. The example is based on SBCL.
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))
Topics: Document MOP