defmetaclass
Thu Aug 23 07:19:30 PDT 2007 Ryszard Szopa <ryszard.szopa@gmail.com>
* defmetaclass
New option for DEFMETACLASS: :validate-subclasses.
diff -rN -u old-mop-utils/mop-utils.lisp new-mop-utils/mop-utils.lisp
--- old-mop-utils/mop-utils.lisp 2014-04-18 15:08:49.000000000 -0700
+++ new-mop-utils/mop-utils.lisp 2014-04-18 15:08:49.000000000 -0700
@@ -8,40 +8,43 @@
(in-package :mop-utils)
-(defmacro defmetaclass (class-name supers slot-definitions &body body)
+(defmacro defmetaclass (metaclass supers slot-definitions &body body)
"Macro for easy metaclass definition. It takes all the options
DEFCLASS takes, plus the following:
- - :VALIDATE-SUPERCLASS, superclasses for which VALIDATE-SUPERCLASS
- methods should be created.
+ - :VALIDATE-SUPERCLASSES, classes for which VALIDATE-SUPERCLASS
+ methods (with METACLASS in the subclass position) will be created.
+
+ - :VALIDATE-SUBCLASSES, a list of classes for which
+ VALIDATE-SUPERCLASS methods (with METACLASS in the superclass
+ position) will be created.
- :SLOT-FIXTUREs, a class from which EFFECTIVE-SLOT-DEFINITION and
DIRECT-SLOT-DEFINITION should inherit.
DEFMETACLASS apart from creating the metaclass defines some additional things:
- - The classes <CLASS-NAME>-DIRECT-SLOT-DEFINITION and
- <CLASS-NAME>-EFFECTIVE-SLOT-DEFINITION (where <CLASS-NAME> should be
- substituted by CLASS-NAME), which inherit from the fixtures and
+ - The classes <METACLASS>-DIRECT-SLOT-DEFINITION and
+ <METACLASS>-EFFECTIVE-SLOT-DEFINITION (where <METACLASS> should be
+ substituted by METACLASS), which inherit from the fixtures and
STANDARD-CLASS-DIRECT-SLOT-DEFINITION and
STANDARD-CLASS-EFFECTIVE-SLOT-DEFINITION, respectively.
- The methods DB-CLASS-{DIRECT|EFFECTIVE}-SLOT-DEFINITION.
- - A VALIDATE-SUPERCLASS method for each class supplied to :VALIDATE-SUPERCLASSES.
-
"
- (let ((superclasses (cdr (assoc :validate-superclasses body)))
+ (let ((new-keywords (list :validate-superclasses :slot-fixtures :validate-subclasses))
+ (subclasses (cdr (assoc :validate-subclasses body)))
+ (superclasses (cdr (assoc :validate-superclasses body)))
(slot-fixtures (cdr (assoc :slot-fixtures body))))
`(progn
- (defclass ,class-name ,supers
+ (defclass ,metaclass ,supers
,slot-definitions
- ,@(remove-if (lambda (sexp) (or (equal :validate-superclasses (car sexp))
- (equal :slot-fixtures (car sexp)))) body))
+ ,@(remove-if (lambda (sexp) (member (car sexp) new-keywords)) body))
,@(when slot-fixtures
- (let ((dir-slot-name (intern (format nil "~A-DIRECT-SLOT-DEFINITION" class-name)))
- (eff-slot-name (intern (format nil "~A-EFFECTIVE-SLOT-DEFINITION" class-name))))
+ (let ((dir-slot-name (intern (format nil "~A-DIRECT-SLOT-DEFINITION" metaclass)))
+ (eff-slot-name (intern (format nil "~A-EFFECTIVE-SLOT-DEFINITION" metaclass))))
`((defclass ,dir-slot-name
(sb-mop:standard-direct-slot-definition ,@slot-fixtures)
@@ -49,20 +52,24 @@
(defclass ,eff-slot-name
(sb-mop:standard-effective-slot-definition ,@slot-fixtures)
())
- (defmethod direct-slot-definition-class ((class ,class-name) &rest initargs)
+ (defmethod direct-slot-definition-class ((class ,metaclass) &rest initargs)
(declare (ignore initargs))
(find-class ',dir-slot-name))
- (defmethod effective-slot-definition-class ((class ,class-name) &rest initargs)
+ (defmethod effective-slot-definition-class ((class ,metaclass) &rest initargs)
(declare (ignore initargs))
(find-class ',eff-slot-name)))))
,@(when superclasses
-
- (loop :for super :in superclasses
- :collect `(defmethod validate-superclass ((class ,class-name)
- (superclass ,super))
- t)))
- (find-class ',class-name))))
+ (loop :for super :in superclasses
+ :collect `(defmethod validate-superclass ((class ,metaclass)
+ (superclass ,super))
+ t)))
+ ,@(when subclasses
+ (loop :for sub :in subclasses
+ :collect `(defmethod validate-superclass ((class ,sub)
+ (superclass ,metaclass))
+ t)))
+ (find-class ',metaclass))))
(defun class-name-of (object)
"The class-name of the class of OBJECT."