| Paste number 21934: | More MOP fun |
| Pasted by: | luis |
| 2 years, 6 months ago | |
| #lisp | |
| Paste contents: |
| ;;;; 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))))) |
This paste has no annotations.