Written on 2023-01-18 by Daniel 'jackdaniel' Kochmański

Introduction
Defining method combinations - the short form
Defining method combinations - the long form
1. The Hooker
2. The Memoizer
Conclusions

Update [2023-01-23]

Christophe Rhodes pointed out that "The Hooker" method combination is not conforming because there are multiple methods with the same "role" that can't be ordered and that have different qualifiers:

Note that two methods with identical specializers, but with different qualifiers, are not ordered by the algorithm described in Step 2 of the method selection and combination process described in Section 7.6.6 (Method Selection and Combination). Normally the two methods play different roles in the effective method because they have different qualifiers, and no matter how they are ordered in the result of Step 2, the effective method is the same. If the two methods play the same role and their order matters, an error is signaled. This happens as part of the qualifier pattern matching in define-method-combination.

http://www.lispworks.com/documentation/HyperSpec/Body/m_defi_4.htm

So instead of using qualifier patterns we should use qualifier predicates. They are not a subject of the above paragraph because of its last sentence (there is also an example in the spec that has multiple methods with a predicate). So instead of

(define-method-combination hooker ()
  (... (hook-before (:before*)) ...) ...)

the method combination should use:

(defun hook-before-p (method-qualifier)
  (typep method-qualifier '(cons (eql :before) (cons t null))))

(define-method-combination hooker ()
  (... (hook-before hook-before-p) ...) ...)

and other "hook" groups should also use predicates.

Another thing worth mentioning is that both ECL and SBCL addressed issues with the qualifier pattern matching and :arguments since the publication of this blog post.

Introduction

Method combinations are used to compute the effective method for a generic function. An effective method is a body of the generic function that combines a set of applicable methods computed based on the invocation arguments.

For example we may have a function responsible for reporting the object status and each method focuses on a different aspect of the object. In that case we may want to append all results into a list:

(defgeneric status (object)
  (:method-combination append))

(defclass base-car ()
  ((engine-status :initarg :engine :accessor engine-status)
   (wheels-status :initarg :wheels :accessor wheels-status)
   (fuel-level :initarg :fuel :accessor fuel-level))
  (:default-initargs :engine 'ok :wheels 'ok :fuel 'full))

(defmethod status append ((object base-car))
  (list :engine (engine-status object)
        :wheels (wheels-status object)
        :fuel (fuel-level object)))

(defclass premium-car (base-car)
  ((gps-status :initarg :gps :accessor gps-status)
   (nitro-level :initarg :nitro :accessor nitro-level))
  (:default-initargs :gps 'no-signal :nitro 'low))

(defmethod status append ((object premium-car))
  (list :gps (gps-status object)
        :nitro (nitro-level object)))

CL-USER> (status (make-instance 'premium-car))
(:GPS NO-SIGNAL :NITRO LOW :ENGINE OK :WHEELS OK :FUEL FULL)

CL-USER> (status (make-instance 'base-car))
(:ENGINE OK :WHEELS OK :FUEL FULL)

The effective method may look like this:

(append (call-method #<method status-for-premium-car>)
        (call-method #<method status-for-base-car>   ))

Note that append is a function so all methods are called. It is possible to use other operators (for example a macro and) and then the invocation of particular methods may be conditional:

(and (call-method #<method can-repair-p-for-premium-car>)
     (call-method #<method can-repair-p-for-base-car>   ))

Defining method combinations - the short form

The short form allows us to define a method combination in the spirit of the previous example:

(OPERATOR (call-method #<m1>)
          (call-method #<m2>)
          ...)

For example we may want to return as the second value the count of odd numbers:

(defun sum-and-count-odd (&rest args)
  (values (reduce #'+ args)
          (count-if #'oddp args)))

(define-method-combination sum-and-count-odd)

(defclass a () ())
(defclass b (a) ())
(defclass c (b) ())

(defgeneric num (o)
  (:method-combination sum-and-count-odd)
  (:method sum-and-count-odd ((o a)) 1)
  (:method sum-and-count-odd ((o b)) 2)
  (:method sum-and-count-odd ((o c)) 3)
  (:method :around ((o c))
    (print "haa!")
    (call-next-method)))

(num (make-instance 'b)) ;; (values 3 1)
(num (make-instance 'c)) ;; (values 6 2)

Note that the short form supports also around methods. It is also important to note that effective methods are cached, that is unless the generic function or the method combination changes, the computation of the effective method may be called only once per the set of effective methods.

Admittedly these examples are not very useful. Usually we operate on data stored in instances and this is not a good abstraction to achieve that. Method combinations are useful to control method invocations and their results. Here is another example:

(defmacro majority-vote (&rest method-calls)
  (let* ((num-methods (length method-calls))
         (tie-methods (/ num-methods 2)))
    `(prog ((yes 0) (no 0))
        ,@(loop for invocation in method-calls
                append `((if ,invocation
                             (incf yes)
                             (incf no))
                         (cond
                           ((> yes ,tie-methods)
                            (return (values t yes no)))
                           ((> no ,tie-methods)
                            (return (values nil yes no))))))
        (error "we have a tie! ~d ~d" yes no))))

(define-method-combination majority-vote)

(defclass a () ())
(defclass b (a) ())
(defclass c (b) ())
(defclass d (c) ())

(defgeneric foo (object param)
  (:method-combination majority-vote)
  (:method majority-vote ((o a) param) nil)
  (:method majority-vote ((o b) param) t)
  (:method majority-vote ((o c) param) t)
  (:method majority-vote ((o d) param) nil))

(foo (make-instance 'a) :whatever) ; (values nil 0 1)
(foo (make-instance 'b) :whatever) ; #<error tie 1 1>
(foo (make-instance 'c) :whatever) ; (values t 2 0)
(foo (make-instance 'd) :whatever) ; #<error tie 2 2>

Defining method combinations - the long form

The long form is much more interesting. It allows us to specify numerous qualifiers and handle methods without any qualifiers at all.

The Hooker

Here we will define a method combination that allows us to define named hooks that are invoked before or after the method. It is possible to have any number of hooks for the same set of arguments (something we can't achieve with the standard :before and :after auxiliary methods):

(defun combine-auxiliary-methods (primary around before after)
  (labels ((call-primary ()
             `(call-method ,(first primary) ,(rest primary)))
           (call-methods (methods)
             (mapcar (lambda (method)
                       `(call-method ,method))
                     methods))
           (wrap-after (the-form)
             (if after
                 `(multiple-value-prog1 ,the-form
                    ,@(call-methods after))
                 the-form))
           (wrap-before (the-form)
             (if before
                 `(progn
                    ,@(call-methods before)
                    ,the-form)
                 the-form))
           (wrap-around (the-form)
             (if around
                 `(call-method ,(first around)
                               (,@(rest around)
                                (make-method ,the-form)))
                 the-form)))
    (wrap-around (wrap-after (wrap-before (call-primary))))))

(define-method-combination hooker ()
  ((normal-before (:before))
   (normal-after  (:after)
                  :order :most-specific-last)
   (normal-around (:around))
   (hook-before   (:before *))
   (hook-after    (:after  *)
                  :order :most-specific-last)
   (hook-around   (:around *))
   (primary () :required t))
  (let ((around (append hook-around normal-around))
        (before (append hook-before normal-before))
        (after  (append normal-after hook-after)))
    (combine-auxiliary-methods primary around before after)))

With this we may define a generic function and associated methods similar to other functions with an extra feature - we may provide named :before, :after and :around methods. Named auxiliary methods take a precedence over unnamed ones. Only after that the specialization is considered. There is one caveat - PCL-derived CLOS implementations (clasp, cmucl, ecl, sbcl) currently ([2023-01-18 śro]) have a bug preventing wildcard qualifier pattern symbol * from working. So better download ccl or wait for fixes. Here's an example for using it:

;;; The protocol.
(defgeneric note-buffer-dimensions-changed (buffer w h)
  (:method (b w h)
    (declare (ignore b w h))
    nil))

(defgeneric change-dimensions (buffer w h)
  (:method-combination hooker))

;;; The implementation of unspecialized methods.
(defmethod change-dimensions :after (buffer w h)
  (note-buffer-dimensions-changed buffer w h))

;;; The stanard class.
(defclass buffer ()
  ((w :initform 0 :accessor w)
   (h :initform 0 :accessor h)))

;;; The implementation for the standard class.
(defmethod change-dimensions ((buffer buffer) w h)
  (print "... Changing the buffer size ...")
  (setf (values (w buffer) (h buffer))
        (values w h)))

(defmethod note-buffer-dimensions-changed ((buffer buffer) w h)
  (declare (ignore buffer w h))
  (print "... Resizing the viewport ..."))

;;; Some dubious-quality third-party code that doesn't want to interfere with
;;; methods defined by the implementation.
(defmethod change-dimensions :after system (buffer w h)
  (print `(log :something-changed ,buffer ,w ,h)))

(defmethod change-dimensions :after my-hook ((buffer buffer) w h)
  (print `(send-email! :me ,buffer ,w ,h)))

CL-USER> (defvar *buffer* (make-instance 'buffer))
*BUFFER*
CL-USER> (change-dimensions *buffer* 10 30)

"... Changing the buffer size ..." 
"... Resizing the viewport ..." 
(LOG :SOMETHING-CHANGED #<BUFFER #x30200088220D> 10 30) 
(SEND-EMAIL! :ME #<BUFFER #x30200088220D> 10 30) 
10
30

The Memoizer

Another example (this time it will work on all implementations) is optional memoization of the function invocation. If we define a method with the qualifier :memoize then the result will be cached depending on arguments. The method combination allows also "normal" auxiliary functions by reusing the function combine-auxiliary-methods from the previous section.

The function ensure-memoized-result accepts the following arguments:

test: compare generations
memo: a form that returns the current generation
cache-key: a list composed of a generic function and its arguments
form: a form implementing the method to be called

When the current generation is nil that means that caching is disabled and we remove the result from the cache. Otherwise we use the test to compare the generation of a cached value and the current one - if they are the same, then the cached value is returned. Otherwise it is returned.

(defparameter *memo* (make-hash-table :test #'equal))
(defun ensure-memoized-result (test memo cache-key form)
  `(let ((new-generation ,memo))
     (if (null new-generation)
         (progn
           (remhash ,cache-key *memo*)
           ,form)
         (destructuring-bind (old-generation . cached-result)
             (gethash ,cache-key *memo* '(nil))
           (apply #'values
                  (if (,test old-generation new-generation)
                      cached-result
                      (rest
                       (setf (gethash ,cache-key *memo*)
                             (list* new-generation (multiple-value-list ,form))))))))))

The method with the qualifier :memoize is used to compute the current generation key. When there is no such method then the function behaves as if the standard method combination is used. The method combination accepts a single argument test, so it is possible to define different predicates for deciding whether the cache is up-to-date or not.

(define-method-combination memoizer (test)
  ((before (:before))
   (after  (:after) :order :most-specific-last)
   (around (:around))
   (memoize (:memoize))
   (primary () :required t))
  (:arguments &whole args)
  (:generic-function function)
  (let ((form (combine-auxiliary-methods primary around before after))
        (memo `(call-method ,(first memoize) ,(rest memoize)))
        (ckey `(list* ,function ,args)))
    (if memoize
        (ensure-memoized-result test memo ckey form)
        form)))

Now let's define a function with "our" method combination. We will use a counter to verify that values are indeed cached.

(defparameter *counter* 0)

(defgeneric test-function (arg &optional opt)
  (:method-combination memoizer eql))

(defmethod test-function ((arg integer) &optional opt)
  (list* `(:counter ,(incf *counter*)) arg opt))

CL-USER> (test-function 42)
((:COUNTER 1) 42)
CL-USER> (test-function 42)
((:COUNTER 2) 42)
CL-USER> (defmethod test-function :memoize ((arg integer) &optional (cache t))
           (and cache :gen-z))
#<STANDARD-METHOD TEST-FUNCTION :MEMOIZE (INTEGER)>
CL-USER> (test-function 42)
((:COUNTER 3) 42)
CL-USER> (test-function 42)
((:COUNTER 3) 42)
CL-USER> (test-function 42 nil)
((:COUNTER 4) 42)
CL-USER> (test-function 42)
((:COUNTER 3) 42)
CL-USER> (test-function 43)
((:COUNTER 5) 43)
CL-USER> (test-function 43)
((:COUNTER 5) 43)
CL-USER> (defmethod test-function :memoize ((arg (eql 43)) &optional (cache t))
           (and cache :gen-x))
#<STANDARD-METHOD TEST-FUNCTION :MEMOIZE ((EQL 43))>
CL-USER> (test-function 43)
((:COUNTER 6) 43)
CL-USER> (test-function 43)
((:COUNTER 6) 43)
CL-USER> (test-function 42)
((:COUNTER 3) 42)

Conclusions

Method combinations are a feature that is often overlooked but give a great deal of control over the generic function invocation. The fact that ccl is the only implementation from a few that I've tried which got method combinations "right" doesn't surprise me - I've always had an impression that it shines in many unexpected places.