1 (in-package :lisp-on-lines
)
3 ;;; * The Description Meta-Meta-Super class.
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
)
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
))
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
))
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
)
28 (apply #'shared-initialize slotd nil
(slot-value
29 (find t direct-slot-definitions
31 :key
#'slot-definition-layer
)
36 ;;; * The Description Meta-Meta class.
37 (defclass description-class
(description-special-layered-access-class layered-class
)
39 (:default-initargs
:defining-metaclass
'description-special-layered-access-class
))
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
)
50 :on
(slot-value slot
'initargs
)
53 (if (eval-attribute-initarg slotd initarg
)
56 (ensure-layered-method
58 `(lambda (description attribute
)
61 :on
(slot-value slot
'initargs
)
63 :nconc
(list (list 'quote
(or (find-slot-name-from-initarg
64 (class-of slotd
) initarg
) initarg
))
67 :in-layer
(slot-definition-layer slot
)
69 :specializers
(list class
(closer-mop:intern-eql-specializer
(closer-mop:slot-definition-name slotd
))))))))
71 (defmethod closer-mop:finalize-inheritance
:after
((class description-class
))
72 (initialize-description-class class
))
74 (define-layered-class description
()
75 ((identity :function
#'identity
))
76 (:metaclass description-class
)
77 (description-layer t
))
79 (eval-when (:load-toplevel
:execute
)
80 (closer-mop:finalize-inheritance
(find-class 'description
)))
83 #+nil
(deflayer description
()
85 (:metaclass description
))
87 #+nil
(defmethod print-object ((object description
) stream
)
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
))
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
)))
108 (defmacro define-description
(name &optional superdescriptions
&body options
)
109 (let ((description-name (defining-description name
)))
111 (destructuring-bind (&optional slots
&rest options
) options
113 (defclass ,description-name
,(append (mapcar #'defining-description superdescriptions
) '(description))
114 ,(if slots slots
'())
116 ,@(unless (assoc :metaclass options
)
117 '((:metaclass description-class
)))
118 (original-name .
,name
))
119 (initialize-description-class (find-description-class ',description-name
))))))