Skip to content

Instantly share code, notes, and snippets.

@luismbo
Created June 6, 2013 15:46
Show Gist options
  • Save luismbo/5722563 to your computer and use it in GitHub Desktop.
Save luismbo/5722563 to your computer and use it in GitHub Desktop.
;;;; ENSURE-SUPERCLASS-MIXIN
;;;
;;; Example usage:
;;;
;;; (defclass foo () ())
;;;
;;; (defclass my-metaclass (ensure-superclass-mixin standard-class)
;;; ()
;;; (:default-initargs
;;; :ensured-superclasses '(foo)))
;;;
;;; (defclass bar ()
;;; ()
;;; (:metaclass my-metaclass))
;;;
;;; (subtypep 'bar 'foo) => T, T
(defclass ensure-superclass-mixin (standard-class)
((ensured-superclasses :accessor ensured-superclasses :initform '()))
(:documentation
"User metaclasses can inherit this mixin in order to ensure
that instances of those metaclasses have certain classes in
their superclasses graph."))
(defun superclass-p (class-name class-list)
"Returns T if one of the classes in CLASS-LIST subclasses the
class designated by CLASS-NAME."
(let ((class-object (find-class class-name)))
(loop for class in class-list
thereis (subtypep class class-object))))
(defun ensure-superclasses (call-next-method class initargs)
(let* ((direct-superclasses (getf initargs :direct-superclases))
(missing (loop for super in (ensured-superclasses class)
unless (superclass-p super direct-superclasses)
collect super)))
(apply call-next-method
class
:direct-superclasses
(append direct-superclasses
(mapcar #'find-class missing))
initargs)))
(defmethod initialize-instance :around
((self ensure-superclass-mixin) &rest initargs &key ensured-superclasses
&allow-other-keys)
"Ensure SELF has ENSURED-SUPERCLASSES in its superclasses."
(setf (ensured-superclasses self) ensured-superclasses)
(ensure-superclasses #'call-next-method self initargs))
(defmethod reinitialize-instance :around
((self ensure-superclass-mixin) &rest initargs
&key (direct-superclasses '() direct-superclasses-p)
(ensured-superclasses '() ensured-superclasses-p)
&allow-other-keys)
"Ensure SELF has (ENSURED-SUPERCLASSES SELF) in its superclasses"
(declare (ignore direct-superclasses))
(when ensured-superclasses-p
(setf (ensured-superclasses self) ensured-superclasses))
(if (not direct-superclasses-p)
(call-next-method)
(ensure-superclasses #'call-next-method self initargs)))
;;;; DEFINE-CUSTOM-SLOT-DEFINITION
;;;
;;; Very ad-hoc abstraction of the common use case of adding new slot
;;; definition options that map directly to the effective slot
;;; definition.
;;;
;;; Example usage:
;;;
;;; (define-custom-slot-definition my-meta-class ()
;;; (special-option1 :initarg :special-option1 :initform nil
;;; :reader special-option1
;;; (special-option2 :initarg :special-option2 :initform nil
;;; :reader special-option2))
;;;
;;; (defclass foo ()
;;; ((bar :special-option1 quux))
;;; (:metaclass my-meta-class))
;;;
;;; (special-option1 (car (class-slots (find-class 'foo))
;;; => QUUX
(defmacro define-custom-slot-definition (metaclass options &body slots)
(declare (ignore options))
(let ((dsd-classname (symbolicate metaclass '#:-direct-slot-definition))
(esd-classname (symbolicate metaclass '#:-effective-slot-definition)))
`(progn
;; Slot definitions.
(defclass ,dsd-classname (standard-direct-slot-definition)
,slots)
(defmethod direct-slot-definition-class ((class ,metaclass) &key)
(find-class ',dsd-classname))
(defclass ,esd-classname (standard-effective-slot-definition)
,slots)
(defmethod effective-slot-definition-class ((class ,metaclass) &key)
(find-class ',esd-classname))
;; Slot computation.
(defmethod compute-effective-slot-definition
((class ,metaclass) slot-name direct-slot-definitions)
(declare (ignore slot-name))
(let ((effective-slotd (call-next-method)))
,@(loop for slotd in (mapcar (compose #'car #'ensure-list) slots)
collect `(setf (slot-value effective-slotd ',slotd)
(slot-value (first direct-slot-definitions)
',slotd)))
effective-slotd)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment