classmethod on CLOS

gistfile1.cl

;; utility functions to define class methods
(defun extract-argument-symbols (args)
  (mapcar #'(lambda (x) (if (listp x) (car x) x)) args))

(defun has-class-method-p (method class arguments)
  (let ((methods (compute-applicable-methods method (cons class arguments))))
    (dolist (m methods)
      (let ((specializers (closer-mop:method-specializers m)))
        (if (typep (car specializers) 'closer-mop:eql-specializer)
            (return-from has-class-method-p t))))
    nil))

;; in clap, we provide define-class-method and define-class-method-default to
;; define classmethods like python.
;; 1.a classmethod should contain the name of class you want to specify as an
;; eql specializer at the first argument.
;;  it means the lambda-list of the method should be
;;  ((class (eql 'your-awesome-class-symbol)) arg2 arg3 ...)
;;
(defmacro define-class-method-default (name arg &optional (documentation nil))
  ;; arg => (class arg2 arg3 ...)
  `(progn
     (defgeneric ,name ,(extract-argument-symbols arg)
       ,@(when documentation (list documentation)))
     ;; a method wrapper for instances of any class.
     (defmethod ,name ((,(car arg) standard-object) ,@(cdr arg))
       ,@(when documentation (list documentation))
       (,name (class-name (class-of ,(car arg)))
              ,@(extract-argument-symbols (cdr arg))))
     ;; a method for any classes...
     (defmethod ,name ,arg
       ,@(when documentation (list documentation))
       (let ((cpl (mapcar #'class-name
                          (closer-mop:class-precedence-list
                           (find-class ,(car arg))))))
         ;; search a valid method...
         (dolist (c (cdr cpl))
           (let ((methods (compute-applicable-methods
                           (symbol-function ',name)
                           (list c ,@(extract-argument-symbols (cdr arg))))))
             (dolist (m methods)
               (let ((specializers (closer-mop:method-specializers m)))
                 ;; class method should eql specialize the 1st argument
                 (if (typep (car specializers) 'closer-mop:eql-specializer)
                     (return-from ,name
                       (funcall (closer-mop:method-function m)
                                (list ,@(extract-argument-symbols arg))
                                nil)))))))
         (error "cannot find applicable classmethod")))))

;; you can write like
;; (define-class-method foo ((self bar-class) arg2 arg3 ...) ...)
(defmacro define-class-method (name arg &rest forms)
  `(defmethod ,name ((,(caar arg) (eql ',(cadr (car arg)))) ,@(cdr arg))
     (labels ((call-next-class-method ()
                (let ((super-classes
                       (mapcar #'class-name
                               (closer-mop:class-precedence-list
                                (find-class ',(cadr (car arg)))))))
                  (dolist (class (cdr super-classes))
                    (if (has-class-method-p (symbol-function ',name)
                                            class
                                            (list
                                             ,@(extract-argument-symbols
                                                (cdr arg))))
                        (return-from call-next-class-method
                          (,name class ,@(extract-argument-symbols
                                          (cdr arg))))))
                  (error "cannot find applicable super classmethod"))))
       ,@forms)))


#|
(defclass hoge () ())
(defclass hogehoge (hoge) ())
(defclass hogehogehoge (hogehoge) ())
(defclass fuga () ())

(closer-mop:finalize-inheritance (find-class 'hoge))
(closer-mop:finalize-inheritance (find-class 'hogehoge))
(closer-mop:finalize-inheritance (find-class 'hogehogehoge))
(closer-mop:finalize-inheritance (find-class 'fuga))

(define-class-method-default my-classmethod (arg))
(define-class-method my-classmethod ((arg hoge)) 'hoge-method)
(define-class-method my-classmethod ((arg hogehogehoge))
  (list (call-next-class-method) 'hogehogehoge-method))

(my-classmethod 'hoge) ; => HOGE-METHOD
(my-classmethod 'hogehoge) ; => HOGE-METHOD
(my-classmethod 'hogehogehoge) ; => (HOGE-METHOD HOGEHOGEHOGE-METHOD)
(my-classmethod (make-instance 'hoge)) ; => HOGE-METHOD
(my-classmethod 'fuga) ; => cannot find applicable method

(define-class-method-default my-classmethod2 (arg (arg2 number)))
(define-class-method my-classmethod2 ((arg hoge) (arg2 number)) 'hoge-method)
(define-class-method my-classmethod2 ((arg hogehogehoge) (arg2 number))
  (list (call-next-class-method) 'hogehogehoge-method))

(my-classmethod2 'hoge 1) ; => HOGE-METHOD
(my-classmethod2 'hogehoge 1) ; => HOGE-METHOD
(my-classmethod2 'hogehogehoge 1) ; => (HOGE-METHOD HOGEHOGEHOGE-METHOD)
(my-classmethod2 (make-instance 'hoge) 1) ; => HOGE-METHOD
(my-classmethod2 'fuga 1) ; => cannot find applicable method
(my-classmethod2 'hoge 'hoge) ; => error
|#