Depending in Common Lisp
Posted on August 26th, 2022.
A while ago I was working on a Common Lisp library that makes use of the Metaobject Protocol. 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 I posted.
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
(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.
Before we get started we'll need Closer to MOP as an implementation compatibility layer:
(ql:quickload :closer-mop)First we define the metaclass:
(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:
(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:
(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:
(defclass user ()
((id :initarg :id)
(name :initarg :name))
(:metaclass monitored-class))And now we can see it in action:
(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:
(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 used to check whether a value was given,
which ensures this works correctly even when setting a slot to nil.
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 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 -pet -peeve of mine. Unfortunately it
happens in a couple of places (even in Common Lisp itself), so it's something to
watch out for.
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:
(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:
(defclass monitored-class (standard-class)
((monitoring-function :initarg :monitoring-function
:accessor monitoring-function
:initform #'log-slot-access))) ; default functionBut 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):
(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:
(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 applying 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 evaling of the
forms the user provides when they don't use it.
Further, suppose a user runs:
(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:
(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:
(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:
(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:
(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:
(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)
; => 999So far, so good. But what happens if we add a subclass of user?
(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:
(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 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.
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:
;; 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)) ; NEWClearly 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:
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:
(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:
(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:
(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:
(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-makunbounding 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:
(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):
(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:
(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:
;; 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:
(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:
- Recompute values of our special metaclass slot(s).
call-next-methodto finish the rest of the (re)initialization.- 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:
(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:
(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:
(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:
(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))foois the superclass, with the default monitoring function.barsubclassesfoobut changes the monitoring function.bazsubclasses foo and inherits its monitoring function.
And everything should work properly:
;; 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:
(defclass foo ()
((x :initarg :x))
(:metaclass monitored-class)
(:monitoring-function #'loud-slot-access))Now foo slot access will be yelled at us:
(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:
(defparameter *bar-object* (make-instance 'bar :x 1))
; => #<BAR {101199A913}>/X <- 1But, crucially, baz was automatically updated to use the new function it
inherits from foo:
(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.