(:title "Depending in Common Lisp"
:snip "Using the CLOS Dependent Maintenance Protocol"
:date "2022-08-26T15:15:00Z"
:draft nil)
A while ago I was working on a Common Lisp library that makes use of the
[Metaobject Protocol](http://metamodular.com/CLOS-MOP/). I ran into a few edge
cases around dependencies between classes and it took a while for me to figure
out how to solve them, so I wanted to write down what I learned in case anyone
else might find it useful. This post is an expanded version of [a Reddit
thread][reddit] I posted.
[reddit]: https://www.reddit.com/r/Common_Lisp/comments/kljyg1/need_advice_on_how_to_handle_metaclass_option/
<div id="toc"></div>
## Setting the Stage
Before we can see the problem, we need a simple example. We'll use the
`monitored-class` metaclass from [The Art of the Metaobject Protocol][amop]
(pages 96-97). Using this class as a metaclass will log all slot reads and
writes, which could be useful for auditing access to certain objects.
[amop]: https://en.wikipedia.org/wiki/The_Art_of_the_Metaobject_Protocol
Before we get started we'll need [Closer to MOP][closer-mop] as an
implementation compatibility layer:
[closer-mop]: https://github.com/pcostanza/closer-mop
```lisp
(ql:quickload :closer-mop)
```
First we define the metaclass:
```lisp
(defclass monitored-class (standard-class)
())
```
Next we'll explicitly say that it's okay for a monitored class to have
superclasses that are standard classes:
```lisp
(defmethod c2mop:validate-superclass
((class monitored-class) (superclass standard-class))
t)
```
And now we can define the actual monitoring functionality. We'll use `:before`
methods on `slot-value-using-class` and its `setf` version to log the reads and
writes of all slots:
```lisp
(defmethod c2mop:slot-value-using-class :before
((class monitored-class) instance slot)
(format t "Reading slot ~A of ~A at ~A.~%"
(c2mop:slot-definition-name slot) instance (get-universal-time)))
(defmethod (setf c2mop:slot-value-using-class) :before
(new-value (class monitored-class) instance slot)
(format t "Setting slot ~A of ~A to ~S at ~A.~%"
(c2mop:slot-definition-name slot) instance new-value (get-universal-time)))
```
With that complete, we can define a new monitored class:
```lisp
(defclass user ()
((id :initarg :id)
(name :initarg :name))
(:metaclass monitored-class))
```
And now we can see it in action:
```lisp
(defparameter *u* (make-instance 'user :id 1 :name "sjl"))
; => Setting slot ID of #<USER {10074DFD33}> to 1 at 3828527923.
; => Setting slot NAME of #<USER {10074DFD33}> to "sjl" at 3828527923.
; => *U*
(slot-value *u* 'id)
; => Reading slot ID of #<USER {10074DFD33}> at 3828527937.
; => 1
(setf (slot-value *u* 'name) "Steve")
; => Setting slot NAME of #<USER {10074DFD33}> to "Steve" at 3828527946.
; => "Steve"
```
### Adding More Flexibility
Now that we have a toy example working, let's make it a little more flexible.
Instead of always generating a string and writing it to standard out, we'll
allow users to provide a `:monitoring-function` as a class option that will
receive the data and can do whatever it wants. For example:
* Logging to syslog instead of standard out.
* Inserting a row into a Postgres database as an audit log.
* Tracking read/write counts in a hash table to find slots that are written more
often than they're read and vice versa.
A monitoring function will receive 2 arguments (the instance and slot name),
plus an optional third argument when a slot is written (the new value). We can
make a default monitoring function that works the same way as before:
```lisp
(defun log-slot-access (instance slot-name &optional (new-value nil new-value?))
(if new-value?
(format t "Setting slot ~A of ~A to ~S at ~A.~%"
slot-name instance new-value (get-universal-time))
(format t "Reading slot ~A of ~A at ~A.~%"
slot-name instance (get-universal-time))))
```
Note the use of the extended `&optional` form with the
[`supplied-p-parameter`][supplied] used to check whether a value was given,
which ensures this works correctly even when setting a slot to `nil`.
[supplied]: http://www.lispworks.com/documentation/HyperSpec/Body/03_dab.htm
Also note how we called it `new-value?` and not `new-value-p` as you'll
sometimes see people do. The `-p` in `new-value-p` stands for "predicate", and
a [predicate][predicate] is a *function* that returns a (generalized) boolean,
*not* a boolean itself. Using a name that ends in `-p` for a boolean value
(rather than for a predicate) is a `-p`et `-p`eeve of mine. Unfortunately it
happens in a couple of places (even in Common Lisp itself), so it's something to
watch out for.
[predicate]: http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#predicate
Now we can update our `monitored-class` to add a slot to store the monitoring
function for each class, and update the `slot-value-using-class` methods to use
that instead of writing the string themselves:
```lisp
(defclass monitored-class (standard-class)
((monitoring-function :initarg :monitoring-function
:accessor monitoring-function)))
(defmethod c2mop:slot-value-using-class :before
((class monitored-class) instance slot)
(funcall (monitoring-function class)
instance
(c2mop:slot-definition-name slot)))
(defmethod (setf c2mop:slot-value-using-class) :before
(new-value (class monitored-class) instance slot)
(funcall (monitoring-function class)
instance
(c2mop:slot-definition-name slot)
new-value))
```
When a user creates a new `monitored-class`, we need to set the
`monitoring-function` slot appropriately. We might initially consider doing
this by having an `initform` for the `monitoring-function` slot in the
metaclass, like this:
```lisp
(defclass monitored-class (standard-class)
((monitoring-function :initarg :monitoring-function
:accessor monitoring-function
:initform #'log-slot-access))) ; default function
```
But this won't work for a number of reasons we'll see shortly. Instead we'll
need to handle the initialization ourselves. We'll do it in `shared-initialize`
so it will happen both when a class is first created and when it's reinitialized
(e.g. after it's redefined):
```lisp
(defun parse-monitoring-function-class-option (arguments)
(case (length arguments)
(1 (eval (first arguments)))
(0 #'log-slot-access)
(t (error "Malformed monitoring-function option."))))
(defmethod shared-initialize :around
((class monitored-class) slot-names
&rest initargs
&key monitoring-function &allow-other-keys)
(apply #'call-next-method class slot-names
:monitoring-function (parse-monitoring-function-class-option
monitoring-function)
initargs))
```
If the user provided a `(:monitoring-function …)` class option we evaluate and
use it, otherwise we default to our simple logging function.
There are a couple of things to note here.
First, when `defclass` gets a class option like `(:monitoring-function foo)`,
what it *actually* passes to the `(re)initialize-instance` methods is the list
`(foo)`. This allows for class options with more than one argument. In our
case we only ever want a single argument, so we ensure the `length` of the
argument is `0` or `1` and handle the cases individually.
Second, `defclass` does not evaluate the class option's arguments. If we say
`(:monitoring-function (lambda (i s &optional v) (print (list i s v))))` what we
get as the initarg will be `((lambda (i s &optional v) (print (list i s v))))`.
That's a list of a list of three elements, *not* a list of an actual function
object. If we want the arguments to be evaluated, we have to do it ourselves.
Unfortunately as far as I can tell there's no way to evaluate these arguments
from `defclass` in their lexical environment — we have to fall back to `eval`
and the null lexical environment. That means that something like this will not
work:
```lisp
(flet ((monitor (instance slot-name &optional new-value)
…))
(defclass foo ()
(…slots…)
(:monitoring-function #'monitor)))
```
I haven't managed to find a way to make this work with `defclass`. If anyone
knows of a solution, please let me know.
Third, you might notice that we're `apply`ing with the full `initargs` list,
which includes the original (unparsed) `monitoring-function`. But that keyword
argument will be shadowed by the `:monitoring-function` we add at the beginning,
so there's no need to bother removing it from `initargs` before we apply (though
it wouldn't hurt to do so). This is another Common Lisp idiom you'll see here
and there when someone wants to override a single keyword argument but preserve
all the rest.
Now we can talk about all the reasons why `:initform #'log-slot-access` doesn't
magically solve all our problems.
First, the `:initform` *would* work properly when you first define a class, but
we still need all the code in `shared-initialize` to do the `eval`ing of the
forms the user provides when they *don't* use it.
Further, suppose a user runs:
```lisp
(defclass foo ()
((some-slot :initarg :some-slot))
(:metaclass monitored-class)
(:monitoring-function monitor-foo))
```
Then later they *remove* the `:monitoring-function` from the `defclass` and
reevaluate it:
```lisp
(defclass foo ()
((some-slot :initarg :some-slot))
(:metaclass monitored-class))
```
What the user (probably) expects here is for the class to have the default
monitoring function. This is what will happen if they start a fresh Lisp image
and load the current code into it. But if we had just used `:initform`, the
class would already have a value for the `monitoring-function` slot (the old
function) and since there's no *new* value being specified, the `:initform`
would never be used and nothing would get updated, so the class would continue
to use the old monitoring function. The user would have to clean things up
manually by killing the class with `(setf (find-class 'foo) nil)` and
reevaluating the `defclass`, or fixing the slot value up manually, or some other
ugly alternative.
With all that out of the way, we can now use a custom `monitoring-function` to
do whatever we want:
```lisp
(defparameter *user-slot-reads* (make-hash-table))
(defparameter *user-slot-writes* (make-hash-table))
(defun track-user-slot-access
(instance slot-name &optional (new-value nil new-value?))
(declare (ignore instance new-value))
(incf (gethash slot-name
(if new-value? *user-slot-writes* *user-slot-reads*)
0)))
(defclass user ()
((id :initarg :id)
(name :initarg :name))
(:metaclass monitored-class)
(:monitoring-function #'track-user-slot-access))
;; Two writes
(defparameter *u* (make-instance 'user :id 1 :name "sjl"))
;; A read
(slot-value *u* 'id)
;; Two more writes
(setf (slot-value *u* 'name) "steve")
(setf (slot-value *u* 'name) "sjl")
;; Results
(alexandria:hash-table-alist *user-slot-reads*)
; => ((ID . 1))
(alexandria:hash-table-alist *user-slot-writes*)
; => ((NAME . 3) (ID . 1))
```
### Toy Example Disclaimer
The `monitored-class` example we've used so far is pretty small, and there are
a number of other ways we could accomplish the same thing, some of which might
not involve metaclasses at all. This might make my example seem overly
complicated.
I wanted to keep the example small so I can focus on the actual problem I ran
into without getting bogged down in too many irrelevant details about a specific
implementation. If you're bothered by how we're using metaclasses here when
there are other ways to implement this toy example, feel free to implement
a more extensive `monitored-class` variant as an exercise:
```lisp
(defclass user ()
((id …)
;; Never monitor this slot:
(session-id … :monitored nil)
;; We only care when this slot *changes*:
(role … :monitored/reads nil)
;; Names are PII, redact their values before logging:
(name … :monitored/redact-value t)
;; Redact the user portion of the email address, logging only the domain:
(email … :monitored/redact-value #'scrub-email))
(:metaclass monitored-class)
(:monitoring-function #'log-to-syslog)
;; Allow us to turn monitoring on/off globally:
(:monitor-when #'monitoring-enabled-p))
```
## The Problem
Let's return to a toy example that will help demonstrate the problem I ran into.
Suppose we have a `user` class and want to monitor that class to log a warning
if someone ever changes the `id` of an instance:
```lisp
(defun monitor-user (instance slot &optional (new-value nil new-value?))
(when (and (eql slot 'id) new-value?)
(when (slot-boundp instance 'id) ; ignore initial setting of the value
(format t "WARNING: User ~A is getting a new ID ~A, this is concerning."
(slot-value instance 'id)
new-value))))
(defclass user ()
((id :initarg :id)
(name :initarg :name))
(:metaclass monitored-class)
(:monitoring-function #'monitor-user))
```
This works as expected:
```lisp
(defparameter *u* (make-instance 'user :id 1 :name "sjl"))
(slot-value *u* 'id)
; => 1
(setf (slot-value *u* 'id) 999)
; WARNING: User 1 is getting a new ID 999, this is concerning.
; => 999
(slot-value *u* 'id)
; => 999
```
So far, so good. But what happens if we add a subclass of user?
```lisp
(defclass paid-user (user)
((plan :initarg :plan :type (member :bronze :silver :gold)))
(:metaclass monitored-class))
(defparameter *p*
(make-instance 'paid-user :id 2 :name "moneybags" :plan :gold))
; => Setting slot ID of #<PAID-USER {100DE55F43}> to 2 at 3870460545.
; => Setting slot NAME of #<PAID-USER {100DE55F43}> to "moneybags" at 3870460545.
; => Setting slot PLAN of #<PAID-USER {100DE55F43}> to :GOLD at 3870460545.
```
We can already see the problem: we didn't explicitly specify
`(:monitoring-function #'monitor-user)` in the `defclass` options, so this class
used the default monitoring function instead of inheriting the monitoring
function from its superclass. This may be what you want in some cases, but for
this case I'd prefer subclasses to inherit their superclass' monitoring function
if they don't explicitly specify one themselves.
When I saw this, my first instinct was to update
`parse-monitoring-function-class-option` to take the class as an extra option
and use that to look up a superclass monitoring function (if any) to use as the
default instead, which would look something like this:
```lisp
(defun monitored-class-p (class)
(typep class 'monitored-class))
(defun first-monitored-superclass (class)
(let ((superclasses (rest (c2mop:class-precedence-list class))))
(first (remove-if-not #'monitored-class-p superclasses))))
(defun parse-monitoring-function-class-option (class arguments)
(case (length arguments)
(1 (eval (first arguments)))
(0 (let ((super (first-monitored-superclass class)))
;; Inherit the monitoring function from its most specific monitored
;; superclass, or use the default if there isn't one.
(if super
(monitoring-function super)
#'log-slot-access)))
(t (error "Malformed monitoring-function option."))))
(defmethod shared-initialize :around
((class monitored-class) slot-names
&rest initargs
&key monitoring-function &allow-other-keys)
(apply #'call-next-method class slot-names
:monitoring-function (parse-monitoring-function-class-option
class monitoring-function)
initargs))
```
Unfortunately, if you try to actually run that code you'll discover a few
unpleasant things. First, the class precedence list isn't available the first
time the class is being initialized. So we can't use it in `shared-initialize`
like this.
Second, I misled you earlier. There's a line [deep in the bowels of the
Metaobject protocol][no-shared-init] that says:
> Portable programs must not define methods on `shared-initialize`.
So we can't use `shared-initialize` as a shortcut *at all*, and will need to
define separate methods for `initialize-instance` and `reinitialize-instance`
after all.
[no-shared-init]: http://metamodular.com/CLOS-MOP/initialization-of-class-metaobjects2.html
But even worse, if we think ahead a little bit (which I, of course, did not do
when I was figuring all this out), we can see this entire strategy is doomed to
failure from the start. Consider the following series of actions by a user at
a REPL:
```lisp
;; Create user class, monitor with default function.
(defclass user ()
((id :initarg :id)
(name :initarg :name))
(:metaclass monitored-class))
;; Create paid user class, inherits monitoring function from user.
(defclass paid-user (user)
((plan :initarg :plan :type (member :bronze :silver :gold)))
(:metaclass monitored-class))
;; Redefine user class, because actually we want to log
;; monitored slots to Postgres.
(defclass user ()
((id :initarg :id)
(name :initarg :name))
(:metaclass monitored-class)
(:monitoring-function #'log-slots-to-postgres)) ; NEW
```
Clearly what should happen here is that the `paid-user` class should now inherit
the *new* monitoring function. But the strategy of trying to set the monitoring
function *once* when a class is initialized or reinitialized falls apart when
you want to support redefinition of superclasses and have their subclasses
inherit changes.
At this point, things are not looking good. We need a new plan.
## The Dependent Maintenance Protocol
Fortunately, as often happens in Common Lisp, the creators of CLOS and the
Metaobject Protocol had a wonderful amount of foresight and provided a way out
of this problem in the form of the [CLOS Dependent Maintenance Protocol][].
From that page:
[CLOS Dependent Maintenance Protocol]: http://metamodular.com/CLOS-MOP/dependent-maintenance-protocol.html
> It is convenient for portable metaobjects to be able to memoize information
> about other metaobjects[…]. Because class […] metaobjects can be
> reinitialized[…], a means must be provided to update this memoized
> information.
This is exactly what we need! We want to memoize the monitoring function each
monitored class will use, and we need to keep that up to date when any of the
classes in the inheritance hierarchy are updated.
The full details are laid out in the protocol documentation, but let's step
through an example here to see it in action.
### Dependency Wrappers
The protocol states:
> To prevent conflicts between two portable programs, or between portable
> programs and the implementation, portable code must not register metaobjects
> themselves as dependents. Instead, portable programs which need to record
> a metaobject as a dependent, should encapsulate that metaobject in some other
> kind of object, and record that object as the dependent.
With this in mind, we'll need to make a small wrapper we can use to store
dependents:
```lisp
(defclass dependency ()
((dependent :accessor dependent :initarg :dep)))
```
And then we'll make some utility functions to add and remove dependencies
to/from classes, which we'll use shortly:
```lisp
(defun dependency= (d class)
"Return whether `d` is a dependency on `class`."
;; We need to filter out any other dependents other code might have added.
(and (typep d 'dependency)
(eql (dependent d) class)))
(defun ensure-dependency (superclass class)
"Ensure that `class` is a dependent of `superclass`."
(c2mop:map-dependents superclass
(lambda (d)
(when (dependency= d class)
(return-from ensure-dependency))))
(c2mop:add-dependent superclass (make-instance 'dependency :dep class)))
(defun ensure-no-dependency (superclass class)
"Ensure that `class` is NOT a dependent of `superclass`."
(c2mop:map-dependents superclass
(lambda (d)
(when (dependency= d class)
(c2mop:remove-dependent superclass d)
(return-from ensure-no-dependency)))))
```
When we define a subclass on a monitored class, e.g. when we ran `(defclass
paid-user (user) …)` before, we'll need to `(ensure-dependency user paid-user)`
to tell CLOS that `paid-user` is dependent on `user`, and needs to be updated if
`user` is changed. We also want to make sure to only add the dependency if it
doesn't already exist, to avoid useless work.
But things can get a little trickier than this, because if `paid-user` is then
redefined to *not* be a subclass of `user` any more (unlikely, but possible) we
want to *remove* that dependency. So we'll need both utility functions for
managing the dependencies.
### Defining the Metaclass
We'll need to update our metaclass to not only store the monitoring function,
but also store what the user *specified* as the monitoring function, in case we
need to recompute it later. We'll also tell Lisp it's okay for a monitored
class to be a subclass of a standard class, add our `slot-value-using-class`
methods from before, and define a helper type predicate while we're here:
```lisp
(defclass monitored-class (standard-class)
((given-monitoring-function
:initarg :given-monitoring-function
:accessor given-monitoring-function)
(computed-monitoring-function
:initarg :computed-monitoring-function
:accessor computed-monitoring-function)))
(defmethod c2mop:validate-superclass
((class monitored-class) (superclass standard-class))
t)
(defmethod c2mop:slot-value-using-class :before
((class monitored-class) instance slot)
(funcall (computed-monitoring-function class)
instance
(c2mop:slot-definition-name slot)))
(defmethod (setf c2mop:slot-value-using-class) :before
(new-value (class monitored-class) instance slot)
(funcall (computed-monitoring-function class)
instance
(c2mop:slot-definition-name slot)
new-value))
(defun monitored-class-p (object)
(typep object 'monitored-class))
```
### Computing Slots
We're going to need a function for computing the value of the slot. It will
serve the same role `parse-monitoring-function-class-option` was serving before.
If we only have one class option like `:monitoring-function` we could hardcode
it into a function like this:
```lisp
(defun recompute-monitoring-function (&key class superclasses value value?)
"Set the metaclass' monitoring-function slots to the appropriate value.
If the user provides an explicit value it will be used, otherwise the value
will be inherited from any superclass' value, otherwise the default will be
used.
In any case, the computed value is stored in the `computed-…` slot, and the
original user-given value (if any) is stored in the `given-…` slot so we can
use it later if any superclasses change and we need to recompute this.
"
;; Only consider monitored superclasses.
(setf superclasses (remove-if-not #'monitored-class-p superclasses))
;; We need to store whether the user gave an explicit value for later.
(if value?
(setf (slot-value class 'given-monitoring-function) value)
(slot-makunbound class 'given-monitoring-function))
;; Set the computed value.
(setf (slot-value class 'computed-monitoring-function)
(cond
;; If the user gave a value, use it (after checking it's well-formed).
(value? (progn (assert (= 1 (length value)))
(eval (first value))))
;; Otherwise, if there are any monitored superclasses, use the most
;; specific one's monitoring function.
(superclasses (slot-value (first superclasses)
'computed-monitoring-function))
;; Otherwise use the default.
(t #'log-slot-access))))
```
First we clean up the superclass list to only consider relevant superclasses.
Then we store the value the user gave, if any, in the
`given-monitoring-function` slot of the class. If they *didn't* specify a value
(e.g. if they *removed* it and reevaluated the `defclass`), we make sure to
account for that by `slot-makunbound`ing the slot to clear out any possible old
value.
Then we compute what the real value should be. If they gave us a value, we
`eval` it as we talked about earlier and use that. Otherwise we use whatever we
computed for a superclass, if available, otherwise the default.
This is all we need if we've only got one option to deal with, as in our toy
example. In my *actual* project I have a bunch of these options, and so added
a slightly-tedious layer of abstraction to avoid the very-tedious copy/paste
approach:
```lisp
(defun recompute-slot
(&key class superclasses computed-slot given-slot value value? default)
"Set the metaclass' slots to the appropriate value.
For metaclass slots if the user provides an explicit value it will be used,
otherwise the value will be inherited from any superclass' value, otherwise
the default will be used.
In any case, the computed value is stored in the `computed-…` slot, and the
original user-given value (if any) is stored in the `given-…` slot so we can
use it later if any superclasses change and we need to recompute this.
"
;; Only consider monitored superclasses.
(setf superclasses (remove-if-not #'monitored-class-p superclasses))
;; We need to store whether the user gave an explicit value for later.
(if value?
(setf (slot-value class given-slot) value)
(slot-makunbound class given-slot))
;; Set the actual value to the given value, or the superclass value,
;; or the default.
(setf (slot-value class computed-slot)
(cond
(value? (progn (assert (= 1 (length value)))
(eval (first value))))
(superclasses (slot-value (first superclasses) computed-slot))
(t default))))
(defun recompute-slots (class &key
direct-superclasses
(monitoring-function nil monitoring-function?)
&allow-other-keys)
(recompute-slot :class class
:superclasses direct-superclasses
:computed-slot 'computed-monitoring-function
:given-slot 'given-monitoring-function
:value monitoring-function
:value? monitoring-function?
:default #'log-slot-access))
```
Supporting more options is just a matter of adding more calls inside of
`recompute-slots`. It's not the most exciting code I've ever written, but it
works.
### Initialization
Now we can finally define the `initialize-instance` and `reinitialize-instance`
methods on our class. We'll start with `initialize-instance` (and a helper
function):
```lisp
(defun strip-initargs (initargs)
"Remove any monitored-class initargs from `initargs`.
We need to do this because we handle these ourselves before
`call-next-method`, in `recompute-slots`, and if we leave them in
the initarg list then `call-next-method` will explode.
"
(loop :for (initarg value) :on initargs :by #'cddr
:unless (member initarg '(:monitoring-function))
:append (list initarg value)))
(defmethod initialize-instance :around
((class monitored-class) &rest initargs &key &allow-other-keys)
(apply #'recompute-slots class initargs)
(apply #'call-next-method class (strip-initargs initargs))
(dolist (superclass (c2mop:class-direct-superclasses class))
(ensure-dependency superclass class)))
```
We recompute our special slots, then delegate to `call-next-method` to handle
everything else, after stripping out our initargs because we've already handled
them.
The only other thing we have to do is plug into the dependent maintenance
protocol, to ensure that this new class is a dependent of all its superclasses.
You might think I'm being wasteful here and we should only add dependencies on
superclasses that are instances of our particular metaclass. For example, if we
have:
```lisp
(defclass some-other-mixin () ())
(defclass user ()
(…slots…)
(:metaclass monitored-class))
(defclass paid-user (user some-other-mixin)
(…slots…)
(:metaclass monitored-class))
```
Then `paid-user` will be a dependent of both `user` *and* `some-other-mixin`.
This seems unnecessary, because changes in non-monitored superclasses won't have
any effect on our monitoring function computation.
Unfortunately, things are not so simple. If we only add dependencies on
monitored superclasses, this will fall apart in the face of [forward-referenced
superclasses][]. In case you weren't aware, Common Lisp allows you to define
a subclass before its superclass, as long as all the classes are in place before
you try to actually make an instance of the subclass:
[forward-referenced superclasses]: http://metamodular.com/CLOS-MOP/class-finalization-protocol.html
```lisp
;; Define a subclass.
(defclass bar (foo)
((b :accessor b :initarg :b)))
;; Trying to make an instance now will signal an error.
(make-instance 'bar :a 1 :b 2)
; => While computing the class precedence list of the class named COMMON-LISP-USER::BAR.
; => The class named COMMON-LISP-USER::FOO is a forward referenced class.
; => The class named COMMON-LISP-USER::FOO is a direct superclass of the class named COMMON-LISP-USER::BAR.
;; Go ahead and define the superclass.
(defclass foo ()
((a :accessor a :initarg :a)))
;; Now we can make an instance of the subclass.
(make-instance 'bar :a 1 :b 2)
; => #<BAR {101144FFC3}>
```
This complicates our lives when we're trying to manage dependents, because we
can't possibly know whether a forward-referenced superclass will eventually be
defined as a monitored class or not. So we'll just take the safe route and add
a dependent to *all* superclasses. This will result in a little extra work, but
it only happens when a class is being defined or redefined which will happen
relatively infrequently.
### Reinitialization
We'll also need to define a method on `reinitialize-instance`:
```lisp
(defmethod reinitialize-instance :around
((class monitored-class) &rest initargs
&key (direct-superclasses nil direct-superclasses?)
&allow-other-keys)
(apply #'recompute-slots class
:direct-superclasses (if direct-superclasses?
direct-superclasses
(c2mop:class-direct-superclasses class))
initargs)
(let ((before (c2mop:class-direct-superclasses class)))
(apply #'call-next-method class (strip-initargs initargs))
(let* ((after (c2mop:class-direct-superclasses class))
(removed (set-difference before after))
(added (set-difference after before)))
(dolist (superclass removed)
(ensure-no-dependency superclass class))
(dolist (superclass added)
(ensure-dependency superclass class)))))
```
The overall structure of this method is the same as `initialize-instance`:
1. Recompute values of our special metaclass slot(s).
2. `call-next-method` to finish the rest of the (re)initialization.
3. Ensure our dependencies are correct.
But there are a couple of fiddly bits to note.
We may or may not get a new set of direct superclasses, depending on how the
reinitialization happened. We *always* need that list when we call
`recompute-slots` though, so we'll grab it ourselves if we don't get it.
We also save the list of direct superclasses before and after we defer to
`call-next-method` to complete the reinitialization, and then compare the list
before and after to figure out which dependencies we need to add or remove.
With all that out of the way, we're almost done.
### Dependent Updates
Now we can finally tell CLOS to update dependents when a monitored class
changes:
```lisp
(defun given-to-initarg (class initarg given-slot)
(when (slot-boundp class given-slot)
(list initarg (slot-value class given-slot))))
(defmethod c2mop:update-dependent
(updated-class (dep dependency) &rest initargs)
(declare (ignore initargs))
(when (monitored-class-p updated-class)
(let ((dependent-class (dependent dep)))
(apply #'reinitialize-instance dependent-class
(append
(given-to-initarg dependent-class
:given-monitoring-function
'given-monitoring-function))))))
```
`update-dependent` is the key method here. When a superclass with one of these
dependencies is updated, this method will be called. When that happens, we know
we might need to update the subclasses.
First we check to make sure the class being updated really *is* a monitored
class (and not something that was forward-referenced but didn't turn out to be
monitored).
Assuming we really are updating a monitored class, we call
`reinitialize-instance` on the dependent class. We set up the initargs to this
call as if the user had reran the *dependent's* `defclass` form (because we're
reinitializing the *dependent*, after the superclass has changed), to ensure
that the recalculation happens properly. An example might make this clearer:
```lisp
(defclass user ()
(…slots…)
(:metaclass monitored-class)
(:monitoring-function #'log-slot))
(defclass paid-user (user)
(…slots…)
(:metaclass monitored-class))
(defclass audited-user (user)
(…slots…)
(:metaclass monitored-class)
(:monitoring-function #'audit-slot-to-postgres))
```
If we now redefine `user`, both of its dependencies will be reinitialized.
For `paid-user` we call `(reinitialize-instance paid-user)` with no initargs,
because there's no `(:monitoring-function …)` in the `defclass` form and thus
its `given-monitoring-function` slot is unbound.
For `audited-user` we call `(reinitialize-instance audited-user
:monitoring-function '(#'audit-slot-to-postgres))`, because the `audited-user`
class *does* have a monitoring function that `recompute-slots` will need.
## The Result
With all that in place, our metaclass is ready for interactive use! First we'll
review the default logging function and create two more:
```lisp
(defun log-slot-access (instance slot-name &optional (new-value nil new-value?))
(if new-value?
(format t "Setting slot ~A of ~A to ~S at ~A.~%"
slot-name instance new-value (get-universal-time))
(format t "Reading slot ~A of ~A at ~A.~%"
slot-name instance (get-universal-time))))
(defun loud-slot-access (instance slot-name &optional (new-value nil new-value?))
(if new-value?
(format t "SETTING SLOT ~A OF ~A TO ~S AT ~A.~%"
slot-name instance new-value (get-universal-time))
(format t "READING SLOT ~A OF ~A AT ~A.~%"
slot-name instance (get-universal-time))))
(defun quiet-slot-access (instance slot-name &optional (new-value nil new-value?))
(if new-value?
(format t "~A/~A <- ~S~%" instance slot-name new-value)
(format t "<- ~A/~A~%" instance slot-name)))
```
Now we can create a few classes:
```lisp
(defclass foo ()
((x :initarg :x))
(:metaclass monitored-class))
(defclass bar (foo)
()
(:metaclass monitored-class)
(:monitoring-function #'quiet-slot-access))
(defclass baz (foo)
()
(:metaclass monitored-class))
```
* `foo` is the superclass, with the default monitoring function.
* `bar` subclasses `foo` but changes the monitoring function.
* `baz` subclasses foo and inherits its monitoring function.
And everything should work properly:
```lisp
;; Foo has the default monitoring function ---------------------
(defparameter *foo-object* (make-instance 'foo :x 1))
; => Setting slot X of #<FOO {101190A513}> to 1 at 3870468582.
(slot-value *foo-object* 'x)
; => Reading slot X of #<FOO {101190A513}> at 3870468645.
(setf (slot-value *foo-object* 'x) 2)
; => Setting slot X of #<FOO {101190A513}> to 2 at 3870468657.
;; Bar has the quiet one ---------------------------------------
(defparameter *bar-object* (make-instance 'bar :x 1))
; => #<BAR {101190EE03}>/X <- 1
(slot-value *bar-object* 'x)
; => <- #<BAR {101190EE03}>/X
(setf (slot-value *bar-object* 'x) 2)
; => #<BAR {101190EE03}>/X <- 2
;; Baz inherits foo's function ---------------------------------
(defparameter *baz-object* (make-instance 'baz :x 1))
; => Setting slot X of #<BAZ {10119142F3}> to 1 at 3870468733.
(slot-value *baz-object* 'x)
; => Reading slot X of #<BAZ {10119142F3}> at 3870468755.
(setf (slot-value *baz-object* 'x) 2)
; => Setting slot X of #<BAZ {10119142F3}> to 2 at 3870468756.
```
And now for the *real* test. We'll redefine *only `foo`* to change its function:
```lisp
(defclass foo ()
((x :initarg :x))
(:metaclass monitored-class)
(:monitoring-function #'loud-slot-access))
```
Now `foo` slot access will be yelled at us:
```lisp
(defparameter *foo-object* (make-instance 'foo :x 1))
; => SETTING SLOT X OF #<FOO {1011998B03}> TO 1 AT 3870469055.
```
`bar` hasn't changed, because it has its own explicit function defined:
```lisp
(defparameter *bar-object* (make-instance 'bar :x 1))
; => #<BAR {101199A913}>/X <- 1
```
But, crucially, `baz` was automatically updated to use the new function it
inherits from `foo`:
```lisp
(defparameter *baz-object* (make-instance 'baz :x 1))
; => SETTING SLOT X OF #<BAZ {101199C293}> TO 1 AT 3870469072.
```
## Is It Worth It?
That was a lot of work. Why did we bother doing it?
One of the strengths of Common Lisp programming is interactive development.
Lispers are used to redefining anything and everything at will and trusting that
their environments can keep up. Interactivity is baked into the bones of the
language — if we want a metaclass to really feel at home, we need to take the
extra steps to make sure it works well in the face of redefinition.
The designers of Common Lisp and the Metaobject Protocol had a lot of foresight
and provided the tools needed to extend the language without destroying its
interactivity. Unfortunately this is a hard problem, and the tools are not
simple to use. It's almost always *possible* to do things right, but is often
not *easy*.
Was it worth doing? For this toy example: probably not. For the project I was
working on when I had to figure this all out: I think it was. For your next
project: you'll need to decide that for yourself. But I, at least, am thankful
that the designers of Common Lisp and CLOS made it *possible* to do things
right, even if it's not always easy.