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)
83 (defmethod initialize-slot-definition-attribute
84 (class (slotd effective-attribute-slot-definition-class
)
85 name direct-slot-definitions
)
86 (let ((tbl (make-hash-table)))
87 (loop for ds in direct-slot-definitions
88 :when
(typep ds
'direct-attribute-slot-definition-class
)
89 :do
(setf (gethash (slot-definition-layer ds
) tbl
)
90 (append (gethash (slot-definition-layer ds
) tbl
'())
91 (slot-definition-attribute-properties ds
))))
93 (let* ((attribute-class (or (getf (gethash t tbl
) :attribute-class
)
94 (description-class-attribute-class class
)))
95 (attribute (apply #'make-instance attribute-class
:name name
'description-class class
(gethash t tbl
))))
96 (maphash (lambda (layer properties
)
97 (pushnew layer
(attribute-layers attribute
))
98 (apply #'initialize-attribute-for-description class attribute layer properties
))
100 (setf (slot-definition-attribute-object slotd
) attribute
)
101 (setf (find-attribute class name
) attribute
))))
103 (defmethod compute-effective-slot-definition
104 ((class standard-description-class
) name direct-slot-definitions
)
105 (declare (ignore name
))
106 (let ((slotd (call-next-method)))
107 (setf (slot-definition-direct-slots slotd
) direct-slot-definitions
)
108 (when (class-finalized-p class
)
109 (initialize-slot-definition-attribute class slotd name direct-slot-definitions
))
112 (defmethod finalize-inheritance :after
((class standard-description-class
))
113 (dolist (slotd (compute-slots class
))
114 (initialize-slot-definition-attribute class slotd
(slot-definition-name slotd
) (slot-definition-direct-slots slotd
))))
116 (defmethod validate-superclass
117 ((class standard-description-class
)
118 (superclass standard-class
))
121 (defmacro defdescription
(name &optional superdescriptions
&body options
)
122 (destructuring-bind (&optional slots
&rest options
) options
123 `(let ((description-name ',name
))
124 (declare (special description-name
))
125 (deflayer ,(defining-description name
) ,(mapcar #'defining-description superdescriptions
)
126 ,(if slots slots
'())
128 ,@(unless (assoc :metaclass options
)
129 '((:metaclass standard-description-class
)))
130 ,@(let ((in-description (assoc :in-description options
)))
132 `((:in-layer .
,(defining-description (cadr in-description
))))))
134 (original-name .
,name
)))))
138 (defmethod initialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '()))
139 (declare (dynamic-extent initargs
))
141 (if (loop for direct-superclass in direct-superclasses
142 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
)))
144 (apply #'call-next-method
147 (append direct-superclasses
148 (list (find-class 'standard-description-object
)))
151 (defmethod reinitialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
152 (declare (dynamic-extent initargs
))
153 ; (warn "CLASS ~A ARGS ~A:" class initargs)
155 (if (or (not direct-superclasses-p
)
156 (loop for direct-superclass in direct-superclasses
157 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
))))
159 (apply #'call-next-method
162 (append direct-superclasses
163 (list (find-class 'standard-description-object
)))
166 (defun find-description (name &optional
(errorp t
))
167 (find-layer (defining-description name
) errorp
))
169 (defun description-class-name (description-class)
170 (ignore-errors (description-original-name (first (class-direct-superclasses description-class
)))))
172 (defmethod print-object ((class standard-description-class
) stream
)
173 (print-unreadable-object (class stream
:type nil
:identity t
)
174 (format stream
"DESCRIPTION-CLASS ~A" (description-class-name class
))))
176 (defun description-name (description)
177 (description-class-name (class-of description
)))
179 (defmethod print-object ((object standard-description-object
) stream
)
180 (print-unreadable-object (object stream
:type nil
:identity t
)
181 (format stream
"DESCRIPTION ~A" (description-name object
))))