classmethod idea w/mop

gistfile1.cl

(defpackage :clap-metas)

(defclass clap-metas::clap-base--meta (standard-class) ())

(defmethod clos:ensure-class-using-class :around ((class null) name
                                                  &rest options
                                                  &key metaclass
                                                       direct-superclasses
                                                  &allow-other-keys)
  (when (not metaclass)
    (let ((parent-meta
           (some (lambda (c)
                   (let ((cl (find-class c)))
                     (clos:finalize-inheritance cl)
                     (some (lambda (cc)
                             (and (typep cc 'clap-metas::clap-base--meta)
                                  (class-of cc)))
                           (clos:class-precedence-list cl))))
                 direct-superclasses)))
      (when parent-meta
        (let ((meta (intern (format nil "~a--meta" name) :clap-metas)))
          (clos:ensure-class meta :direct-superclasses `(,(class-name parent-meta)))
          (setf options `(:metaclass ,meta ,@options))))))
  (apply #'call-next-method class name options))

(defmacro define-class-generic (name (arg &rest args) &rest options)
  `(progn
     (defgeneric ,name (arg ,@args) ,@options)
     (defmethod ,name ((class symbol) ,@args)
       (,name (find-class class) ,@args))))

(defmacro define-class-method (name ((arg class-name) &rest args) &body body)
  (let ((meta (intern (format nil "~a--meta" class-name) :clap-metas)))
    `(defmethod ,name ((class ,meta) ,@args) ,@body)))

(defclass clap-base () () (:metaclass clap-metas::clap-base--meta))


#|

(defclass my-class1 (clap-base) ())

(defclass my-class2 (my-class1) ())

(define-class-generic classmeth (class x) (:documentation "sample"))

(define-class-method classmeth ((class clap-base) x) `("Base" ,x))

(define-class-method classmeth ((class my-class2) x) `("Derived" ,x))

;;(classmeth 'clap-base 'a) => ("Base" a)
;;(classmeth 'my-class1 'a) => ("Base" a)
;;(classmeth 'my-class2 'a) => ("Derived" a)

|#