1 (in-package :lisp-on-lines
)
3 ;;;; SLOT-DEFINITION META-OBJECTS
4 (define-layered-class direct-attribute-slot-definition-class
5 (special-layered-direct-slot-definition
6 contextl
::singleton-direct-slot-definition
)
7 ((attribuite-properties
8 :accessor slot-definition-attribute-properties
9 :documentation
"Holds the initargs passed to the slotd")))
11 (defmethod initialize-instance
12 :after
((slotd direct-attribute-slot-definition-class
)
14 (setf (slot-definition-attribute-properties slotd
) initargs
))
16 (defmethod reinitialize-instance
17 :after
((slotd direct-attribute-slot-definition-class
)
19 (setf (slot-definition-attribute-properties slotd
) initargs
))
21 (define-layered-class effective-attribute-slot-definition-class
22 (special-layered-effective-slot-definition)
23 ((direct-slots :accessor slot-definition-direct-slots
)
25 :accessor slot-definition-attribute-object
)))
27 ;;;; DESCRIPTION-ACCESS-CLASS, the PARTIAL-CLASS defining class for DESCRIPTIONs
28 (define-layered-class description-access-class
29 (standard-layer-class contextl
::special-layered-access-class
)
30 ((defined-in-descriptions :initarg
:in-description
)
31 (class-active-attributes-definition :initarg
:attributes
)
32 (mixin-class-p :initarg
:mixinp
)
33 (description-name :initarg original-name
35 :reader description-original-name
)))
37 (defmethod direct-slot-definition-class
38 ((class description-access-class
) &key
&allow-other-keys
)
39 (find-class 'direct-attribute-slot-definition-class
))
41 (defmethod effective-slot-definition-class
42 ((class description-access-class
) &key
&allow-other-keys
)
43 (find-class 'effective-attribute-slot-definition-class
))
46 ;;;;STANDARD-DESCRIPTION
47 (defclass standard-description-class
(description-access-class layered-class
)
48 ((attributes :accessor description-class-attributes
:initform
(make-hash-table :test
#'eq
)))
49 (:default-initargs
:defining-metaclass
'description-access-class
))
51 (defclass standard-description-object
52 (standard-layer-object)
53 ((described-object :accessor described-object
56 (ACTIVE-ATTRIBUTES :LABEL
"Attributes" :VALUE NIL
:ACTIVEP NIL
58 (ACTIVE-DESCRIPTIONS :LABEL
"Active Descriptions" :VALUE NIL
59 :ACTIVEP NIL
:KEYWORD
:ACTIVATE
)
60 (INACTIVE-DESCRIPTIONS :LABEL
"Inactive Descriptions" :VALUE NIL
61 :ACTIVEP NIL
:KEYWORD
:DEACTIVATE
))
62 (:METACLASS description-access-class
)
63 (ORIGINAL-NAME . STANDARD-DESCRIPTION-OBJECT
))
66 (defgeneric find-attribute
(description-designator attribute-name
&optional errorp
)
67 (:method
((description standard-description-class
) attribute-name
&optional
(errorp t
))
68 (or (gethash attribute-name
(description-class-attributes description
))
70 (when errorp
(error "No attribute named ~A found in class ~A" attribute-name description
)))))
71 (:method
((description standard-description-object
) attribute-name
&optional
(errorp t
))
72 (find-attribute (class-of description
) attribute-name errorp
))
73 (:method
((description symbol
) attribute-name
&optional
(errorp t
))
74 (find-attribute (find-description description
) attribute-name errorp
)))
76 (defgeneric (setf find-attribute
) (value description attribute-name
)
77 (:method
(value (description standard-description-class
) attribute-name
)
78 (setf (gethash attribute-name
(description-class-attributes description
)) value
)))
80 (defmethod description-class-attribute-class (description)
84 (defmethod initialize-slot-definition-attribute
85 (class (slotd effective-attribute-slot-definition-class
)
86 name direct-slot-definitions
)
87 (let ((tbl (make-hash-table)))
88 (loop for ds in direct-slot-definitions
89 :when
(typep ds
'direct-attribute-slot-definition-class
)
90 :do
(setf (gethash (slot-definition-layer ds
) tbl
)
91 (append (gethash (slot-definition-layer ds
) tbl
'())
92 (slot-definition-attribute-properties ds
))))
94 (let* ((attribute-class (or (block nil
95 (maphash (lambda (k v
)
96 (let ((class (getf v
:attribute-class
)))
97 (when class
(return class
))))
99 (description-class-attribute-class class
)))
100 (attribute (apply #'make-instance attribute-class
:name name
'description-class class
(gethash t tbl
))))
101 (maphash (lambda (layer properties
)
102 (pushnew layer
(attribute-layers attribute
))
103 (apply #'initialize-attribute-for-description class attribute layer properties
))
105 (setf (slot-definition-attribute-object slotd
) attribute
)
106 (setf (find-attribute class name
) attribute
))))
108 (defmethod compute-effective-slot-definition
109 ((class standard-description-class
) name direct-slot-definitions
)
110 (declare (ignore name
))
111 (let ((slotd (call-next-method)))
112 (setf (slot-definition-direct-slots slotd
) direct-slot-definitions
)
113 (when (class-finalized-p class
)
114 (initialize-slot-definition-attribute class slotd name direct-slot-definitions
))
117 (defmethod finalize-inheritance :after
((class standard-description-class
))
118 (dolist (slotd (compute-slots class
))
119 (initialize-slot-definition-attribute class slotd
(slot-definition-name slotd
) (slot-definition-direct-slots slotd
))))
121 (defmethod validate-superclass
122 ((class standard-description-class
)
123 (superclass standard-class
))
126 (defmacro defdescription
(name &optional superdescriptions
&body options
)
127 (destructuring-bind (&optional slots
&rest options
) options
128 `(let ((description-name ',name
))
129 (declare (special description-name
))
130 (deflayer ,(defining-description name
) ,(mapcar #'defining-description superdescriptions
)
131 ,(if slots slots
'())
133 ,@(unless (assoc :metaclass options
)
134 '((:metaclass standard-description-class
)))
135 ,@(let ((in-description (assoc :in-description options
)))
137 `((:in-layer .
,(defining-description (cadr in-description
))))))
139 (original-name .
,name
)))))
143 (defmethod initialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '()))
144 (declare (dynamic-extent initargs
))
146 (if (loop for direct-superclass in direct-superclasses
147 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
)))
149 (apply #'call-next-method
152 (append direct-superclasses
153 (list (find-class 'standard-description-object
)))
156 (defmethod reinitialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
157 (declare (dynamic-extent initargs
))
158 ; (warn "CLASS ~A ARGS ~A:" class initargs)
160 (if (or (not direct-superclasses-p
)
161 (loop for direct-superclass in direct-superclasses
162 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
))))
164 (apply #'call-next-method
167 (append direct-superclasses
168 (list (find-class 'standard-description-object
)))
171 (defun find-description (name &optional
(errorp t
))
172 (find-layer (defining-description name
) errorp
))
174 (defun description-class-name (description-class)
175 (ignore-errors (description-original-name (first (class-direct-superclasses description-class
)))))
177 (defmethod print-object ((class standard-description-class
) stream
)
178 (print-unreadable-object (class stream
:type nil
:identity t
)
179 (format stream
"DESCRIPTION-CLASS ~A" (description-class-name class
))))
181 (defun description-name (description)
182 (description-class-name (class-of description
)))
184 (defmethod print-object ((object standard-description-object
) stream
)
185 (print-unreadable-object (object stream
:type nil
:identity t
)
186 (format stream
"DESCRIPTION ~A" (description-name object
))))