initial commit
Thu Aug 23 01:21:01 PDT 2007 Ryszard Szopa <ryszard.szopa@gmail.com>
* initial commit
diff -rN -u old-mop-utils/mop-utils.asd new-mop-utils/mop-utils.asd
--- old-mop-utils/mop-utils.asd 1969-12-31 16:00:00.000000000 -0800
+++ new-mop-utils/mop-utils.asd 2014-07-22 02:20:21.000000000 -0700
@@ -0,0 +1,17 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
+
+(in-package :asdf)
+
+(defpackage mop-utils-system
+ (:use :cl :asdf))
+
+(in-package :mop-utils-system)
+
+(defsystem mop-utils
+ :name "MOP-utils"
+ :version "0.0.1"
+ :components ((:file "mop-utils"))
+ :description "A set of Metaobject Protocol utilities."
+ :author "Ryszard Szopa"
+ :depends-on (#-sbcl :closer-mop))
+
\ No newline at end of file
diff -rN -u old-mop-utils/mop-utils.lisp new-mop-utils/mop-utils.lisp
--- old-mop-utils/mop-utils.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-mop-utils/mop-utils.lisp 2014-07-22 02:20:21.000000000 -0700
@@ -0,0 +1,66 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
+
+(in-package :asdf)
+(defpackage mop-utils
+ (:use :cl :closer-mop)
+ (:documentation "A set of Metaobject Protocol utilities.")
+ (:use #+sbcl :sb-mop #-sbcl :closer-mop)
+ (:export #:defmetaclass))
+
+(in-package :mop-utils)
+
+(defmacro defmetaclass (class-name 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.
+
+ - :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
+ 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)))
+ (slot-fixtures (cdr (assoc :slot-fixtures body))))
+ `(progn
+
+ ,@(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))))
+
+ `((defclass ,dir-slot-name
+ (sb-mop:standard-direct-slot-definition ,@slot-fixtures)
+ ())
+ (defclass ,eff-slot-name
+ (sb-mop:standard-direct-slot-definition ,@slot-fixtures)
+ ())
+ (defmethod direct-slot-definition-class ((class ,class-name) &rest initargs)
+ (declare (ignore initargs))
+ (find-class ',dir-slot-name))
+
+ (defmethod effective-slot-definition-class ((class ,class-name) &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)))
+ (defclass ,class-name ,supers
+ ,slot-definitions
+
+ ,@(remove-if (lambda (sexp) (or (equal :validate-superclasses (car sexp))
+ (equal :slot-fixtures (car sexp)))) body)))))