gistfile1.cl

(require :closer-mop)
(defpackage :clap-metas)

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

(defmethod closer-mop:ensure-class-using-class :around ((class null) name
                                                        &rest options
                                                        &key metaclass
                                                        direct-superclasses
                                                        &allow-other-keys)
  (when (not metaclass)                 ;if :metaclass is not specified
    (let ((parent-meta
           (some (lambda (c)
                   (let ((cl (find-class c)))
                     (closer-mop:finalize-inheritance cl) ;ensure finalize-inheritance
                     ;; find a class derived from clap-metas:clap-base--meta
                     (some (lambda (cc)
                             (and (typep cc 'clap-metas::clap-base--meta)
                                  (class-of cc)))
                           (closer-mop:class-precedence-list cl))))
                 direct-superclasses)))
      (when parent-meta
        (let ((meta (intern (format nil "~a--meta" name) :clap-metas)))
          ;; create a new meta class for CLASS
          (closer-mop: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)))


(defmethod closer-mop:validate-superclass ((class clap-metas::clap-base--meta)
                                           (superclass standard-class))
  t)

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

#|
;; these are invalid...
(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)

|#