Commit | Line | Data |
---|---|---|
6d0aa5eb | 1 | (in-package :lisp-on-lines) |
2 | ||
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"))) | |
10 | ||
11 | (defmethod initialize-instance | |
12 | :after ((slotd direct-attribute-slot-definition-class) | |
13 | &rest initargs) | |
14 | (setf (slot-definition-attribute-properties slotd) initargs)) | |
15 | ||
16 | (defmethod reinitialize-instance | |
17 | :after ((slotd direct-attribute-slot-definition-class) | |
18 | &rest initargs) | |
19 | (setf (slot-definition-attribute-properties slotd) initargs)) | |
20 | ||
21 | (define-layered-class effective-attribute-slot-definition-class | |
22 | (special-layered-effective-slot-definition) | |
23 | ((direct-slots :accessor slot-definition-direct-slots) | |
24 | (attribute-object | |
25 | :accessor slot-definition-attribute-object))) | |
26 | ||
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 | |
34 | :initform nil | |
35 | :reader description-original-name))) | |
36 | ||
37 | (defmethod direct-slot-definition-class | |
38 | ((class description-access-class) &key &allow-other-keys) | |
39 | (find-class 'direct-attribute-slot-definition-class)) | |
40 | ||
41 | (defmethod effective-slot-definition-class | |
42 | ((class description-access-class) &key &allow-other-keys) | |
43 | (find-class 'effective-attribute-slot-definition-class)) | |
44 | ||
45 | ||
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)) | |
50 | ||
51 | (defclass standard-description-object | |
52 | (standard-layer-object) | |
53 | ((described-object :accessor described-object | |
54 | :special t | |
55 | :function 'identity) | |
56 | (ACTIVE-ATTRIBUTES :LABEL "Attributes" :VALUE NIL :ACTIVEP NIL | |
57 | :KEYWORD :ATTRIBUTES) | |
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)) | |
64 | ||
65 | ||
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)) | |
69 | (when errorp | |
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))) | |
75 | ||
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))) | |
79 | ||
80 | (defmethod description-class-attribute-class (description) | |
81 | 'standard-attribute) | |
82 | ||
f8bb47cc | 83 | |
6d0aa5eb | 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)))) | |
93 | ||
f8bb47cc DC |
94 | (let* ((attribute-class (or (block nil |
95 | (maphash (lambda (k v) | |
96 | (let ((class (getf v :attribute-class))) | |
97 | (when class (return class)))) | |
98 | tbl)) | |
6d0aa5eb | 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)) | |
104 | tbl) | |
105 | (setf (slot-definition-attribute-object slotd) attribute) | |
106 | (setf (find-attribute class name) attribute)))) | |
107 | ||
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)) | |
115 | slotd)) | |
116 | ||
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)))) | |
120 | ||
121 | (defmethod validate-superclass | |
122 | ((class standard-description-class) | |
123 | (superclass standard-class)) | |
124 | t) | |
125 | ||
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 '()) | |
132 | ,@options | |
133 | ,@(unless (assoc :metaclass options) | |
134 | '((:metaclass standard-description-class))) | |
135 | ,@(let ((in-description (assoc :in-description options))) | |
136 | (when in-description | |
137 | `((:in-layer . ,(defining-description (cadr in-description)))))) | |
138 | ||
139 | (original-name . ,name))))) | |
140 | ||
141 | ||
142 | ||
143 | (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '())) | |
144 | (declare (dynamic-extent initargs)) | |
145 | (prog1 | |
146 | (if (loop for direct-superclass in direct-superclasses | |
147 | thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))) | |
148 | (call-next-method) | |
149 | (apply #'call-next-method | |
150 | class | |
151 | :direct-superclasses | |
152 | (append direct-superclasses | |
153 | (list (find-class 'standard-description-object))) | |
154 | initargs)))) | |
155 | ||
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) | |
159 | (prog1 | |
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)))) | |
163 | (call-next-method) | |
164 | (apply #'call-next-method | |
165 | class | |
166 | :direct-superclasses | |
167 | (append direct-superclasses | |
168 | (list (find-class 'standard-description-object))) | |
169 | initargs)))) | |
170 | ||
171 | (defun find-description (name &optional (errorp t)) | |
172 | (find-layer (defining-description name) errorp)) | |
173 | ||
174 | (defun description-class-name (description-class) | |
175 | (ignore-errors (description-original-name (first (class-direct-superclasses description-class))))) | |
176 | ||
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)))) | |
180 | ||
181 | (defun description-name (description) | |
182 | (description-class-name (class-of description))) | |
183 | ||
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)))) |