;;;; 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)))))