GOOPS-like generic dispatch in CL, a quick sketch

README.md

GOOPS has GFs which can have a variable number of arguments while still permitting the programmer to specialize on them. This is a quick draft of a CL version that I've done recently and decided to share for fun and profit.

The main issue here is to avoid the fact that methods which agree on parameter specializers and qualifiers as per CLHS 7.6.3 are gonna get overwritten, and we don't want that. GOOPS-like dispatch must mean a maximum of 0 required arguments in defmethod, which means that we get to specialize on exactly 0 arguments, which means that, trivially, 7.6.3 points 1 and 2 are always going to be true.

Hence, only 7.6.3 point 3 is left for us - and that means qualifiers. I (ab)use those in this example, by using a lax method combination (to still have :before/:after/:around) and passing class names this way. It also means that all method lambda lists are effectively (&rest args) or something similar, since we have no required args and &key would bring confusion about function arity. Lambda lists with a "real" &rest, like (foo bar . baz) in Scheme, are not implemented. No idea if &optional works.

The implementation completely replaces the compute-discriminating-function of the main generic function. The whole idea is: check the arity of the arglist, use this to access an internal vector of proper "proxy" generic functions, apply the proxy function to the arguments. Hence, method calls defined on the same number of arguments should still be cached by the implementation with each call having only a minor overhead of a single standard closure call + getting the length of the arglist.

compute-applicable-methods is also written, and it returns the outside method objects, which are also not the method objects which were added but specially massaged versions of them which instead directly call the "proxy" method that was created. These should also work when called directly since there's some code to ensure this, but I haven't checked that.

Creation of proxy GFs is managed via add-method. The naming of "proxies" is probably not the best either, since the main GF is actually a proxy which calls the "real" code stored internally.

In case anyone dares use it, it's just a quick hack that was done for fun; finishing and testing and completing this is left as an exercise for the reader.

goops.lisp

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload '(:alexandria :closer-mop :method-combination-utilities)))

(defpackage #:goops-gf
  (:use #:cl)
  (:local-nicknames (#:a #:alexandria)
                    (#:m #:closer-mop)
                    (#:mcu #:method-combination-utilities)))

(in-package #:goops-gf)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Method definition

(defclass goops-method (m:standard-method)
  ((%goops-specializers :initarg :goops-specializers
                        :reader goops-specializers)))

(defmethod initialize-instance ((method goops-method)
                                &rest args
                                &key qualifiers)
  (let* ((class-names (cdr (member :goops qualifiers)))
         (classes (mapcar #'find-class class-names)))
    (apply #'call-next-method method :goops-specializers classes args)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GF class definition

;; TODO this probably warrants a redefinition lock somewhere to prevent races.

(defclass goops-generic-function (m:standard-generic-function)
  ((%proxies :initarg :proxies :reader goops-gf-proxies)
   (%from-proxy :initarg :methods-from :reader goops-gf-from-proxy)
   (%to-proxy :initarg :methods-to :reader goops-gf-to-proxy))
  (:default-initargs
   :proxies (make-array 0 :adjustable t :fill-pointer t)
   :methods-from (make-hash-table)
   :methods-to (make-hash-table)
   :method-combination (m:find-method-combination #'make-instance 'mcu:lax nil))
  (:metaclass m:funcallable-standard-class))

(defmethod m:generic-function-method-class ((gf goops-generic-function))
  (find-class 'goops-method))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Method proxying

(defun ensure-proxy-count (gf nargs)
  (flet ((make-proxy (gf n)
           (make-instance
            'standard-generic-function
            :lambda-list (a:make-gensym-list n)
            :declarations (m:generic-function-declarations gf)
            :method-combination (m:generic-function-method-combination gf)
            :name (a:symbolicate (m:generic-function-name gf) "-PROXY-"
                                 (prin1-to-string n)))))
    (let* ((proxies (goops-gf-proxies gf))
           (nproxies (1- (length proxies))))
      (loop for n from nproxies below nargs
            for proxy = (make-proxy gf (1+ n))
            do (vector-push-extend proxy proxies)
            finally (return gf)))))

(defmethod add-method ((gf goops-generic-function) (method goops-method))
  (let* ((nargs (length (goops-specializers method))))
    (ensure-proxy-count gf nargs)
    (let* ((proxy (elt (goops-gf-proxies gf) nargs))
           (specializers (goops-specializers method))
           (all-qualifiers (method-qualifiers method))
           (qualifiers (subseq all-qualifiers
                               0 (position :goops all-qualifiers)))
           (proxy-function (m:method-function method))
           (proxy-documentation (format nil "Proxy method for ~S with ~D args."
                                        gf nargs))
           (proxy-method (make-instance 'standard-method
                                        :documentation proxy-documentation
                                        :function proxy-function
                                        :lambda-list (a:make-gensym-list nargs)
                                        :specializers specializers
                                        :qualifiers qualifiers))
           (real-function (lambda (&rest args) (apply proxy-function args)))
           (real-documentation (format nil "Real method for ~S with ~D args."
                                       gf nargs))
           (real-method (make-instance 'standard-method
                                       :documentation real-documentation
                                       :function real-function
                                       :lambda-list '(&rest args)
                                       :specializers '()
                                       :qualifiers all-qualifiers)))
      (setf (gethash real-method (goops-gf-to-proxy gf)) proxy-method
            (gethash proxy-method (goops-gf-from-proxy gf)) real-method)
      (add-method proxy proxy-method)
      (add-method gf real-method))))

(defmethod remove-method :before ((gf goops-generic-function)
                                  (real-method goops-method))
  ;; Just clear the backlinks for now.
  (let* ((proxy-method (gethash real-method (goops-gf-to-proxy gf)))
         (proxy-gf (m:method-generic-function proxy-method)))
    (remove-method proxy-gf proxy-method)
    (remhash proxy-method (goops-gf-from-proxy gf))
    (remhash real-method (goops-gf-to-proxy gf))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Applicable methods

(defmethod compute-applicable-methods ((gf goops-generic-function) args)
  (let ((nargs (length args))
        (max-nargs (1- (length (goops-gf-proxies gf)))))
    (if (< max-nargs nargs)
        '()
        (let ((proxy (elt (goops-gf-proxies gf) nargs)))
          (mapcar (lambda (x) (gethash x (goops-gf-from-proxy gf)))
                  (compute-applicable-methods proxy args))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Discriminating function

(defmethod m:compute-discriminating-function ((gf goops-generic-function))
  (let* ((slots (m:class-slots (find-class 'goops-generic-function)))
         (slot (find '%proxies slots :key #'m:slot-definition-name))
         (location (m:slot-definition-location slot)))
    (flet ((goops-dispatch (&rest args)
             (declare (optimize speed))
             (let* ((nargs (length args))
                    (proxies (m:funcallable-standard-instance-access
                              gf location))
                    (proxy (aref proxies nargs)))
               (declare (type (and (vector t) (not simple-array)) proxies))
               (declare (type function proxy))
               (apply proxy args))))
      #'goops-dispatch)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Example code

(progn (m:finalize-inheritance (find-class 'goops-method))
       (m:finalize-inheritance (find-class 'goops-generic-function)))

(defgeneric foo (&rest args)
  (:generic-function-class goops-generic-function))

(defmethod foo :goops (&rest args)
  (declare (ignore args))
  :nothing)

(defmethod foo :goops number (&rest args)
  (declare (ignore args))
  :number)

(defmethod foo :goops number number (&rest args)
  (declare (ignore args))
  :two-numbers)

(defmethod foo :goops ratio ratio (&rest args)
  (declare (ignore args))
  :two-ratios)

(defmethod foo :around :goops t t (&rest args)
  (declare (ignore args))
  (list :around (call-next-method)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; REPL tests

GOOPS-GF> (foo)
:NOTHING

GOOPS-GF> (foo 42)
:NUMBER

GOOPS-GF> (foo 42 42)
(:AROUND :TWO-NUMBERS)

GOOPS-GF> (foo 1/2 3/4)
(:AROUND :TWO-RATIOS)

GOOPS-GF> (compute-applicable-methods #'foo '())
(#<STANDARD-METHOD GOOPS-GF::FOO :GOOPS () {1001B053B3}>)

GOOPS-GF> (compute-applicable-methods #'foo '(1))
(#<STANDARD-METHOD GOOPS-GF::FOO :GOOPS NUMBER () {1001B053A3}>)

GOOPS-GF> (compute-applicable-methods #'foo '(1 2))
(#<STANDARD-METHOD GOOPS-GF::FOO :GOOPS NUMBER NUMBER () {1001B05393}>
 #<STANDARD-METHOD GOOPS-GF::FOO :AROUND :GOOPS T T () {100565B773}>)

GOOPS-GF> (compute-applicable-methods #'foo '(1/2 2/3))
(#<STANDARD-METHOD GOOPS-GF::FOO :GOOPS RATIO RATIO () {1001B05383}>
 #<STANDARD-METHOD GOOPS-GF::FOO :GOOPS NUMBER NUMBER () {1001B05393}>
 #<STANDARD-METHOD GOOPS-GF::FOO :AROUND :GOOPS T T () {100565B773}>)