Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Class construction protocol | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Sensble Object Design, an object system for C. | |
11 | ;;; | |
12 | ;;; SOD is free software; you can redistribute it and/or modify | |
13 | ;;; it under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 2 of the License, or | |
15 | ;;; (at your option) any later version. | |
16 | ;;; | |
17 | ;;; SOD is distributed in the hope that it will be useful, | |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with SOD; if not, write to the Free Software Foundation, | |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
25 | ||
26 | (cl:in-package #:sod) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Classes. | |
30 | ||
31 | (export 'make-sod-class) | |
32 | (defun make-sod-class (name superclasses pset &optional location) | |
33 | "Construct and return a new SOD class with the given NAME and SUPERCLASSES. | |
34 | ||
35 | This is the main constructor function for classes. The protocol works as | |
36 | follows. The `:lisp-class' property in PSET is checked: if it exists, it | |
37 | must be a symbol naming a (CLOS) class, which is used in place of | |
38 | `sod-class'. All of the arguments are then passed to `make-instance'; | |
39 | further behaviour is left to the standard CLOS instance construction | |
40 | protocol; for example, `sod-class' defines an `:after'-method on | |
3109662a | 41 | `shared-initialize'. |
dea4d055 MW |
42 | |
43 | Minimal sanity checking is done during class construction; most of it is | |
3109662a | 44 | left for `finalize-sod-class' to do (via `check-sod-class'). |
dea4d055 MW |
45 | |
46 | Unused properties in PSET are diagnosed as errors." | |
47 | ||
48 | (with-default-error-location (location) | |
49 | (let* ((pset (property-set pset)) | |
50 | (class (make-instance (get-property pset :lisp-class :symbol | |
51 | 'sod-class) | |
52 | :name name | |
53 | :superclasses superclasses | |
54 | :location (file-location location) | |
55 | :pset pset))) | |
56 | (check-unused-properties pset) | |
57 | class))) | |
58 | ||
59 | (export 'guess-metaclass) | |
60 | (defgeneric guess-metaclass (class) | |
61 | (:documentation | |
62 | "Determine a suitable metaclass for the CLASS. | |
63 | ||
64 | The default behaviour is to choose the most specific metaclass of any of | |
65 | the direct superclasses of CLASS, or to signal an error if that failed.")) | |
66 | ||
67 | ;;;-------------------------------------------------------------------------- | |
68 | ;;; Slots and slot initializers. | |
69 | ||
70 | (export 'make-sod-slot) | |
71 | (defgeneric make-sod-slot (class name type pset &optional location) | |
72 | (:documentation | |
73 | "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS. | |
74 | ||
75 | This is the main constructor function for slots. This is a generic | |
76 | function primarily so that the CLASS can intervene in the construction | |
77 | process. The default method uses the `:lisp-class' property (defaulting | |
78 | to `sod-slot') to choose a (CLOS) class to instantiate. The slot is then | |
79 | constructed by `make-instance' passing the arguments as initargs; further | |
80 | behaviour is left to the standard CLOS instance construction protocol; for | |
81 | example, `sod-slot' defines an `:after'-method on `shared-initialize'. | |
82 | ||
83 | Unused properties on PSET are diagnosed as errors.")) | |
84 | ||
85 | (export 'make-sod-instance-initializer) | |
86 | (defgeneric make-sod-instance-initializer | |
87 | (class nick name value-kind value-form pset &optional location) | |
88 | (:documentation | |
89 | "Construct and attach an instance slot initializer, to CLASS. | |
90 | ||
91 | This is the main constructor function for instance initializers. This is | |
92 | a generic function primarily so that the CLASS can intervene in the | |
93 | construction process. The default method looks up the slot using | |
94 | `find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to | |
95 | actually make the initializer object, and adds it to the appropriate list | |
96 | in CLASS. | |
97 | ||
98 | Unused properties on PSET are diagnosed as errors.")) | |
99 | ||
100 | (export 'make-sod-class-initializer) | |
101 | (defgeneric make-sod-class-initializer | |
102 | (class nick name value-kind value-form pset &optional location) | |
103 | (:documentation | |
104 | "Construct and attach a class slot initializer, to CLASS. | |
105 | ||
106 | This is the main constructor function for class initializers. This is a | |
107 | generic function primarily so that the CLASS can intervene in the | |
108 | construction process. The default method looks up the slot using | |
109 | `find-class-slot-by-name', calls `make-sod-initializer-using-slot' to | |
110 | actually make the initializer object, and adds it to the appropriate list | |
111 | in CLASS. | |
112 | ||
113 | Unused properties on PSET are diagnosed as errors.")) | |
114 | ||
115 | (export 'make-sod-initializer-using-slot) | |
116 | (defgeneric make-sod-initializer-using-slot | |
117 | (class slot init-class value-kind value-form pset location) | |
118 | (:documentation | |
119 | "Common construction protocol for slot initializers. | |
120 | ||
121 | This generic function does the common work for constructing instance and | |
122 | class initializers. It can usefully be specialized according to both the | |
123 | class and slot types. The default method uses the `:lisp-class' property | |
124 | (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate. The | |
125 | slot is then constructed by `make-instance' passing the arguments as | |
126 | initargs; further behaviour is left to the standard CLOS instance | |
127 | construction protocol; for example, `sod-initializer' defines an | |
128 | `:after'-method on `shared-initialize'. | |
129 | ||
130 | Diagnosing unused properties is left for the caller (usually | |
131 | `make-sod-instance-initializer' or `make-sod-class-initializer') to do. | |
132 | The caller is also expected to have set `with-default-error-location' if | |
133 | appropriate. | |
134 | ||
135 | You are not expected to call this generic function directly; it's more | |
136 | useful as a place to hang methods for custom initializer classes.")) | |
137 | ||
138 | ;;;-------------------------------------------------------------------------- | |
139 | ;;; Messages and methods. | |
140 | ||
141 | (export 'make-sod-message) | |
142 | (defgeneric make-sod-message (class name type pset &optional location) | |
143 | (:documentation | |
144 | "Construct and attach a new message with given NAME and TYPE, to CLASS. | |
145 | ||
146 | This is the main constructor function for messages. This is a generic | |
147 | function primarily so that the CLASS can intervene in the construction | |
148 | process. The default method uses the `:lisp-class' property (defaulting | |
149 | to `sod-message') to choose a (CLOS) class to instantiate. The message is | |
150 | then constructed by `make-instance' passing the arguments as initargs; | |
151 | further behaviour is left to the standard CLOS instance construction | |
152 | protocol; for example, `sod-message' defines an `:after'-method on | |
153 | `shared-initialize'. | |
154 | ||
155 | Unused properties on PSET are diagnosed as errors.")) | |
156 | ||
157 | (export 'make-sod-method) | |
158 | (defgeneric make-sod-method | |
159 | (class nick name type body pset &optional location) | |
160 | (:documentation | |
161 | "Construct and attach a new method to CLASS. | |
162 | ||
163 | This is the main constructor function for methods. This is a generic | |
164 | function primarily so that the CLASS can intervene in the message lookup | |
165 | process, though this is actually a fairly unlikely occurrence. | |
166 | ||
167 | The default method looks up the message using `find-message-by-name', | |
168 | invokes `make-sod-method-using-message' to make the method object, and | |
169 | then adds the method to the class's list of methods. This split allows | |
170 | the message class to intervene in the class selection process, for | |
171 | example. | |
172 | ||
173 | Unused properties on PSET are diagnosed as errors.")) | |
174 | ||
175 | (export 'make-sod-method-using-message) | |
176 | (defgeneric make-sod-method-using-message | |
177 | (message class type body pset location) | |
178 | (:documentation | |
179 | "Main construction subroutine for method construction. | |
180 | ||
181 | This is a generic function so that it can be specialized according to both | |
182 | a class and -- more particularly -- a message. The default method uses | |
183 | the `:lisp-class' property (defaulting to the result of calling | |
184 | `sod-message-method-class') to choose a (CLOS) class to instantiate. The | |
185 | method is then constructed by `make-instance' passing the arguments as | |
186 | initargs; further behaviour is left to the standard CLOS instance | |
187 | construction protocol; for example, `sod-method' defines an | |
188 | `:after'-method on `shared-initialize'. | |
189 | ||
190 | Diagnosing unused properties is left for the caller (usually | |
191 | `make-sod-method') to do. The caller is also expected to have set | |
192 | `with-default-error-location' if appropriate. | |
193 | ||
194 | You are not expected to call this generic function directly; it's more | |
195 | useful as a place to hang methods for custom method classes.")) | |
196 | ||
197 | (export 'sod-message-method-class) | |
198 | (defgeneric sod-message-method-class (message class pset) | |
199 | (:documentation | |
200 | "Return the preferred class for methods on MESSAGE. | |
201 | ||
202 | The message can inspect the PSET to decide on a particular message. A | |
203 | `:lisp-class' property will usually override this decision: it's then the | |
204 | programmer's responsibility to ensure that the selected method class is | |
205 | appropriate.")) | |
206 | ||
207 | (export 'check-message-type) | |
208 | (defgeneric check-message-type (message type) | |
209 | (:documentation | |
210 | "Check that TYPE is a suitable type for MESSAGE. Signal errors if not. | |
211 | ||
212 | This is separated out of `shared-initialize', where it's called, so that | |
213 | it can be overridden conveniently by subclasses.")) | |
214 | ||
215 | (export 'check-method-type) | |
216 | (defgeneric check-method-type (method message type) | |
217 | (:documentation | |
218 | "Check that TYPE is a suitable type for METHOD. Signal errors if not. | |
219 | ||
220 | This is separated out of `shared-initialize', where it's called, so that | |
221 | it can be overridden conveniently by subclasses.")) | |
222 | ||
223 | ;;;-------------------------------------------------------------------------- | |
224 | ;;; Builder macros. | |
225 | ||
226 | (export 'define-sod-class) | |
227 | (defmacro define-sod-class (name (&rest superclasses) &body body) | |
228 | "Construct a new SOD class called NAME in the current module. | |
229 | ||
230 | The new class has the named direct SUPERCLASSES, which should be a list of | |
231 | strings. | |
232 | ||
233 | The BODY begins with a sequence of alternating keyword/value pairs | |
234 | defining properties for the new class. The keywords are (obviously) not | |
235 | evaluated, but the value forms are. | |
236 | ||
237 | The remainder of the BODY are a sequence of forms to be evaluated as an | |
238 | implicit `progn'. Additional macros are available to the BODY, to make | |
239 | defining the class easier. | |
240 | ||
241 | In the following, NAME is a string giving a C identifier; NICK is a string | |
242 | giving the nickname of a superclass; TYPE is a C type using S-expression | |
243 | notation. | |
244 | ||
245 | * message NAME TYPE &rest PLIST | |
246 | ||
247 | * method NICK NAME TYPE BODY &rest PLIST | |
248 | ||
249 | * slot NAME TYPE &rest PLIST | |
250 | ||
251 | * instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST | |
252 | ||
253 | * class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST" | |
254 | ||
255 | (let ((plist nil) | |
256 | (classvar (gensym "CLASS-"))) | |
257 | (loop | |
258 | (when (or (null body) | |
259 | (not (keywordp (car body)))) | |
260 | (return)) | |
261 | (push (pop body) plist) | |
262 | (push (pop body) plist)) | |
263 | `(let ((,classvar (make-sod-class ,name | |
264 | (mapcar #'find-sod-class | |
265 | (list ,@superclasses)) | |
266 | (make-property-set | |
267 | ,@(nreverse plist))))) | |
268 | (macrolet ((message (name type &rest plist) | |
269 | `(make-sod-message ,',classvar ,name (c-type ,type) | |
270 | (make-property-set ,@plist))) | |
271 | (method (nick name type body &rest plist) | |
272 | `(make-sod-method ,',classvar ,nick ,name (c-type ,type) | |
273 | ,body (make-property-set ,@plist))) | |
274 | (slot (name type &rest plist) | |
275 | `(make-sod-slot ,',classvar ,name (c-type ,type) | |
276 | (make-property-set ,@plist))) | |
277 | (instance-initializer | |
278 | (nick name value-kind value-form &rest plist) | |
279 | `(make-sod-instance-initializer ,',classvar ,nick ,name | |
280 | ,value-kind ,value-form | |
281 | (make-property-set | |
282 | ,@plist))) | |
283 | (class-initializer | |
284 | (nick name value-kind value-form &rest plist) | |
285 | `(make-sod-class-initializer ,',classvar ,nick ,name | |
286 | ,value-kind ,value-form | |
287 | (make-property-set | |
288 | ,@plist)))) | |
289 | ,@body | |
290 | (finalize-sod-class ,classvar) | |
291 | (add-to-module *module* ,classvar))))) | |
292 | ||
293 | ;;;----- That's all, folks -------------------------------------------------- |