The Art of the Metaobject Protocol, and ENSURE-CLASS-USING-CLASS

In the Art of the Metaobject Protocol (AMOP), the authors present a metaobject protocol (MOP) for the Common Lisp Object System (CLOS). The MOP seems to have become a de-facto standard, with different Common Lisp (CL) implementations offering different (small?) extensions atop it, and varying a bit in how they’ve interpreted the MOP specification. See e.g. the SBCL manual section on the MOP. However, the MOP as presented in AMOP wasn’t intended as a standard. Quoting from its introduction: “This protocol is not offered as a proposed standard, but as a basis for experimentation, which may subsequently lead to the development of a revised and standardized CLOS metaobject protocol.”

Well, time for an experiment.

I’ve previously noted that I find the design of ENSURE-CLASS-USING-CLASS odd. Basically, a DEFCLASS expands into a call to ENSURE-CLASS which calls ENSURE-CLASS-USING-CLASS. But ENSURE-CLASS-USING-CLASS has a keyword METACLASS parameter (which defaults to STANDARD-CLASS). It would have been a lot cleaner, I think (and this is the experiment/hypothesis) if METACLASS were a required parameter and ENSURE-CLASS provided it in the call instead. Since METACLASS isn’t a required parameter, it can’t be specialized on.

This is a problem for me, because my use-case requires me to intercept class (re-)definitions whether the class exists already or not. Hence, I want to promote METACLASS into a required parameter. Compare:

ensure-class-using-class class name &key :direct-default-initargs :direct-slots :direct-superclasses :name :metaclass => resulting-class

(The fact that NAME occurs as both a required parameter and a keyword parameter is surely a typo in AMOP – it’s a required one.)

ensure-class-using-metaclass metaclass class name &key :direct-default-initargs :direct-slots :direct-superclasses  => resulting-class

Now that I can specialize on METACLASS, I can build up – and make available the capability of building up – method combinations, with :before, :after and :around methods. Of course, since a CL implementation (with MOP) has ENSURE-CLASS-USING-CLASS as responsible for generating a class, implementing ENSURE-CLASS-USING-METACLASS is a little tricky. I’ve come up with the following hack, however:

(eval-when (:compile-toplevel :load-toplevel :execute)
  (intern "ENSURE-CLASS-USING-METACLASS" 'c2mop)
  (export (find-symbol "ENSURE-CLASS-USING-METACLASS" 'c2mop) 'c2mop))

(defgeneric c2mop:ensure-class-using-metaclass
    (metaclass class name
     &key direct-default-initargs direct-slots direct-superclasses %ecuc-method &allow-other-keys)
  (:documentation "Extend the MOP since ENSURE-CLASS-USING-CLASS doesn't allow specializing on the metaclass.

%ECUC-METHOD should be a lambda that wraps CALL-NEXT-METHOD in ENSURE-CLASS-USING-CLASS, so that we
can leave the 'main body of work' in the same place as before. This is an implementation hack.
See the :around method on ENSURE-CLASS-USING-CLASS. The base method for ENSURE-CLASS-USING-METACLASS
just funcalls %ECUC-METHOD appropriately."))

(defmethod c2mop:ensure-class-using-class :around
    (class name &rest args &key (metaclass 'standard-class) &allow-other-keys)
  (assert (or (symbolp metaclass) (c2mop:classp metaclass)))
  (let ((metaclass (if (symbolp metaclass) (find-class metaclass) metaclass))
        (%ecuc-method
          (lambda (class name &key direct-default-initargs direct-slots direct-superclasses metaclass)
            (apply #'call-next-method
                   class
                   name
                   :direct-default-initargs direct-default-initargs
                   :direct-slots direct-slots
                   :direct-superclasses direct-superclasses
                   :metaclass metaclass
                   ;; And, so we'll capture implementation-specific extras:
                   args))))
    (apply #'c2mop:ensure-class-using-metaclass metaclass class name :%ecuc-method %ecuc-method args)))

(defmethod c2mop:ensure-class-using-metaclass
    (metaclass class name
     &key direct-default-initargs direct-slots direct-superclasses %ecuc-method &allow-other-keys)
  (funcall %ecuc-method
           class
           name
           :direct-default-initargs direct-default-initargs
           :direct-slots direct-slots
           :direct-superclasses direct-superclasses
           :metaclass metaclass))

This is exploratory code, and I’m sure I’ll discover some little nuisance about it eventually and decide to tidy up the interfaces somehow. But with this change, I can specialize on METACLASS like I need to. So unless there’s some unforeseen issue that makes this approach untenable, I’ll consider my experiment validated if this lets me accomplish what I’m trying to do. (The hacky implementation is admittedly somewhat unfortunate, though.)