| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | ;;; * The Description Meta-Meta-Super class. |
| 4 | |
| 5 | (defclass description-special-layered-access-class |
| 6 | (contextl::special-layered-access-class) |
| 7 | ((original-name :initarg original-name) |
| 8 | (description-layer :initarg description-layer) |
| 9 | (instance))) |
| 10 | |
| 11 | (defmethod closer-mop:direct-slot-definition-class |
| 12 | ((class description-special-layered-access-class) |
| 13 | &key &allow-other-keys) |
| 14 | (find-class 'attribute-special-layered-direct-slot-definition)) |
| 15 | |
| 16 | (defmethod closer-mop:effective-slot-definition-class |
| 17 | ((class description-special-layered-access-class) |
| 18 | &key name &allow-other-keys) |
| 19 | (declare (ignore name)) |
| 20 | (find-class 'standard-attribute)) |
| 21 | |
| 22 | (defmethod closer-mop:compute-effective-slot-definition :around |
| 23 | ((class description-special-layered-access-class) name direct-slot-definitions) |
| 24 | (declare (ignore name)) |
| 25 | (let ((slotd (call-next-method))) |
| 26 | (setf (slot-value slotd 'direct-slots) direct-slot-definitions) |
| 27 | |
| 28 | (apply #'shared-initialize slotd nil (slot-value |
| 29 | (find t direct-slot-definitions |
| 30 | :test #'eq |
| 31 | :key #'slot-definition-layer ) |
| 32 | 'initargs)) |
| 33 | |
| 34 | slotd)) |
| 35 | |
| 36 | ;;; * The Description Meta-Meta class. |
| 37 | (defclass description-class (description-special-layered-access-class layered-class) |
| 38 | () |
| 39 | (:default-initargs :defining-metaclass 'description-special-layered-access-class)) |
| 40 | |
| 41 | (defun initialize-description-class (class) |
| 42 | (let ((description (make-instance class))) |
| 43 | (setf (slot-value class 'instance) description) |
| 44 | (dolist (slotd (closer-mop:class-slots class)) |
| 45 | (setf (slot-value slotd 'description) description) |
| 46 | (dolist (slot (slot-value slotd 'direct-slots)) |
| 47 | (setf (slot-value slot 'initargs) |
| 48 | (loop |
| 49 | :for (initarg value) |
| 50 | :on (slot-value slot 'initargs) |
| 51 | :by #'cddr |
| 52 | :nconc (list initarg |
| 53 | (if (eval-attribute-initarg slotd initarg) |
| 54 | (eval value) |
| 55 | value)))) |
| 56 | (ensure-layered-method |
| 57 | 'special-slot-values |
| 58 | `(lambda (description attribute) |
| 59 | (list ,@(loop |
| 60 | :for (initarg value) |
| 61 | :on (slot-value slot 'initargs) |
| 62 | :by #'cddr |
| 63 | :nconc (list (list 'quote (or (find-slot-name-from-initarg |
| 64 | (class-of slotd) initarg) initarg)) |
| 65 | |
| 66 | value)))) |
| 67 | :in-layer (slot-definition-layer slot) |
| 68 | :qualifiers '(append) |
| 69 | :specializers (list class (closer-mop:intern-eql-specializer (closer-mop:slot-definition-name slotd)))))))) |
| 70 | |
| 71 | (defmethod closer-mop:finalize-inheritance :after ((class description-class)) |
| 72 | (initialize-description-class class)) |
| 73 | |
| 74 | (define-layered-class description () |
| 75 | ((identity :function #'identity)) |
| 76 | (:metaclass description-class) |
| 77 | (description-layer t)) |
| 78 | |
| 79 | (eval-when (:load-toplevel :execute) |
| 80 | (closer-mop:finalize-inheritance (find-class 'description))) |
| 81 | |
| 82 | ;;; The layer itself. |
| 83 | #+nil(deflayer description () |
| 84 | () |
| 85 | (:metaclass description)) |
| 86 | |
| 87 | #+nil (defmethod print-object ((object description) stream) |
| 88 | (call-next-method)) |
| 89 | |
| 90 | (defgeneric find-description-class (name &optional errorp) |
| 91 | ;; !-- Sometimes it gets inited, sometimes it don't. |
| 92 | (:method :around (name &optional errorp) |
| 93 | (let ((class (call-next-method))) |
| 94 | (unless (slot-boundp class 'instance) |
| 95 | (initialize-description-class class)) |
| 96 | class)) |
| 97 | (:method ((name (eql t)) &optional errorp) |
| 98 | (declare (ignore errorp)) |
| 99 | (find-class 'description t)) |
| 100 | (:method ((name symbol) &optional errorp) |
| 101 | (or (find-class (defining-description name) errorp) |
| 102 | (find-description-class t))) |
| 103 | (:method ((description description) &optional errorp) |
| 104 | (declare (ignore errorp)) |
| 105 | (class-of description))) |
| 106 | |
| 107 | ;;; A handy macro. |
| 108 | (defmacro define-description (name &optional superdescriptions &body options) |
| 109 | (let ((description-name (defining-description name))) |
| 110 | |
| 111 | (destructuring-bind (&optional slots &rest options) options |
| 112 | `(prog1 |
| 113 | (defclass ,description-name ,(append (mapcar #'defining-description superdescriptions) '(description)) |
| 114 | ,(if slots slots '()) |
| 115 | ,@options |
| 116 | ,@(unless (assoc :metaclass options) |
| 117 | '((:metaclass description-class))) |
| 118 | (original-name . ,name)) |
| 119 | (initialize-description-class (find-description-class ',description-name)))))) |
| 120 | |
| 121 | |
| 122 | |