-
-
Save garaemon/732960 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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) | |
|# |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment