Skip to content

Instantly share code, notes, and snippets.

@garaemon
Created December 7, 2010 18:07
Show Gist options
  • Save garaemon/732160 to your computer and use it in GitHub Desktop.
Save garaemon/732160 to your computer and use it in GitHub Desktop.
classmethod on CLOS
;; 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
|#
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment