Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Equipment for building classes and friends | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Simple Object Definition system. | |
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 | ;;; Finding things by name | |
30 | ||
31 | (defun find-superclass-by-nick (class nick) | |
32 | "Returns the superclass of CLASS with nickname NICK, or signals an error." | |
33 | (or (find nick (sod-class-precedence-list class) | |
34 | :key #'sod-class-nickname | |
35 | :test #'string=) | |
36 | (error "No superclass of `~A' with nickname `~A'" | |
37 | (sod-class-name class) nick))) | |
38 | ||
39 | (flet ((find-item-by-name (what class list name key) | |
40 | (or (find name list :key key :test #'string=) | |
41 | (error "No ~A in class `~A' with name `~A'" | |
42 | what (sod-class-name class) name)))) | |
43 | ||
44 | (defun find-instance-slot-by-name (class super-nick slot-name) | |
45 | (let ((super (find-superclass-by-nick class super-nick))) | |
46 | (find-item-by-name "slot" super (sod-class-slots super) | |
47 | slot-name #'sod-slot-name))) | |
48 | ||
49 | (defun find-class-slot-by-name (class super-nick slot-name) | |
50 | (let* ((meta (sod-class-metaclass class)) | |
51 | (super (find-superclass-by-nick meta super-nick))) | |
52 | (find-item-by-name "slot" super (sod-class-slots super) | |
53 | slot-name #'sod-slot-name))) | |
54 | ||
55 | (defun find-message-by-name (class super-nick message-name) | |
56 | (let ((super (find-superclass-by-nick class super-nick))) | |
57 | (find-item-by-name "message" super (sod-class-messages super) | |
58 | message-name #'sod-message-name)))) | |
59 | ||
60 | ;;;-------------------------------------------------------------------------- | |
61 | ;;; Class construction. | |
62 | ||
63 | (defun make-sod-class (name superclasses pset &optional location) | |
64 | "Construct and return a new SOD class with the given NAME and SUPERCLASSES. | |
65 | ||
66 | This is the main constructor function for classes. The protocol works as | |
67 | follows. The :LISP-CLASS property in PSET is checked: if it exists, it | |
68 | must be a symbol naming a (CLOS) class, which is used in place of | |
69 | SOD-CLASS. All of the arguments are then passed to MAKE-INSTANCE; further | |
70 | behaviour is left to the standard CLOS instance construction protocol; for | |
71 | example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE. | |
72 | ||
73 | Minimal sanity checking is done during class construction; most of it is | |
74 | left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS). | |
75 | ||
76 | Unused properties in PSET are diagnosed as errors." | |
77 | ||
78 | (with-default-error-location (location) | |
79 | (let ((class (make-instance (get-property pset :lisp-class :symbol | |
80 | 'sod-class) | |
81 | :name name | |
82 | :superclasses superclasses | |
83 | :location (file-location location) | |
84 | :pset pset))) | |
85 | (check-unused-properties pset) | |
86 | class))) | |
87 | ||
88 | (defgeneric guess-metaclass (class) | |
89 | (:documentation | |
90 | "Determine a suitable metaclass for the CLASS. | |
91 | ||
92 | The default behaviour is to choose the most specific metaclass of any of | |
93 | the direct superclasses of CLASS, or to signal an error if that failed.")) | |
94 | ||
95 | (defmethod guess-metaclass ((class sod-class)) | |
96 | "Default metaclass-guessing function for classes. | |
97 | ||
98 | Return the most specific metaclass of any of the CLASS's direct | |
99 | superclasses." | |
100 | (do ((supers (sod-class-direct-superclasses class) (cdr supers)) | |
101 | (meta nil (let ((candidate (sod-class-metaclass (car supers)))) | |
102 | (cond ((null meta) candidate) | |
103 | ((sod-subclass-p meta candidate) meta) | |
104 | ((sod-subclass-p candidate meta) candidate) | |
105 | (t (error "Unable to choose metaclass for `~A'" | |
106 | (sod-class-name class))))))) | |
107 | ((endp supers) meta))) | |
108 | ||
109 | (defmethod shared-initialize :after ((class sod-class) slot-names &key pset) | |
110 | "Specific behaviour for SOD class initialization. | |
111 | ||
112 | Properties inspected are as follows: | |
113 | ||
114 | * :METACLASS names the metaclass to use. If unspecified, NIL is stored, | |
115 | and (unless you intervene later) GUESS-METACLASS will be called by | |
116 | FINALIZE-SOD-CLASS to find a suitable default. | |
117 | ||
118 | * :NICK provides a nickname for the class. If unspecified, a default | |
119 | (the class's name, forced to lowercase) will be chosen in | |
120 | FINALIZE-SOD-CLASS. | |
121 | ||
122 | * :CHAIN names the chained superclass. If unspecified, this class will | |
123 | be left at the head of its chain." | |
124 | ||
125 | (macrolet ((default-slot (slot value) | |
126 | `(unless (slot-boundp class ',slot) | |
127 | (setf (slot-value class ',slot) ,value)))) | |
128 | ||
129 | ;; If no nickname, copy the class name. It won't be pretty, though. | |
130 | (default-slot nickname | |
131 | (get-property pset :nick :id (slot-value class 'name))) | |
132 | ||
133 | ;; If no metaclass, guess one in a (Lisp) class-specific way. | |
134 | (default-slot metaclass | |
135 | (multiple-value-bind (name floc) (get-property pset :metaclass :id) | |
136 | (if floc | |
137 | (find-sod-class name floc) | |
138 | (guess-metaclass class)))) | |
139 | ||
140 | ;; If no chained-superclass, then start a new chain here. | |
141 | (default-slot chained-superclass | |
142 | (multiple-value-bind (name floc) (get-property pset :chain :id) | |
143 | (if floc | |
144 | (find-sod-class name floc) | |
145 | nil))))) | |
146 | ||
147 | ;;;-------------------------------------------------------------------------- | |
148 | ;;; Slot construction. | |
149 | ||
150 | (defgeneric make-sod-slot (class name type pset &optional location) | |
151 | (:documentation | |
152 | "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS. | |
153 | ||
154 | This is the main constructor function for slots. This is a generic | |
155 | function primarily so that the CLASS can intervene in the construction | |
156 | process. The default method uses the :LISP-CLASS property (defaulting to | |
157 | SOD-SLOT) to choose a (CLOS) class to instantiate. The slot is then | |
158 | constructed by MAKE-INSTANCE passing the arguments as initargs; further | |
159 | behaviour is left to the standard CLOS instance construction protocol; for | |
160 | example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE. | |
161 | ||
162 | Unused properties on PSET are diagnosed as errors.")) | |
163 | ||
164 | (defmethod make-sod-slot | |
165 | ((class sod-class) name type pset &optional location) | |
166 | (with-default-error-location (location) | |
167 | (let ((slot (make-instance (get-property pset :lisp-class :symbol | |
168 | 'sod-slot) | |
169 | :class class | |
170 | :name name | |
171 | :type type | |
172 | :location (file-location location) | |
173 | :pset pset))) | |
174 | (with-slots (slots) class | |
175 | (setf slots (append slots (list slot)))) | |
176 | (check-unused-properties pset)))) | |
177 | ||
178 | (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset) | |
179 | "This method exists so that it isn't an error to provide a :PSET initarg | |
180 | to (make-instance 'sod-slot ...). It does nothing." | |
181 | (declare (ignore slot-names pset)) | |
182 | nil) | |
183 | ||
184 | ;;;-------------------------------------------------------------------------- | |
185 | ;;; Slot initializer construction. | |
186 | ||
187 | (defgeneric make-sod-instance-initializer | |
188 | (class nick name value-kind value-form pset &optional location) | |
189 | (:documentation | |
190 | "Construct and attach an instance slot initializer, to CLASS. | |
191 | ||
192 | This is the main constructor function for instance initializers. This is | |
193 | a generic function primarily so that the CLASS can intervene in the | |
194 | construction process. The default method looks up the slot using | |
195 | FIND-INSTANCE-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to | |
196 | actually make the initializer object, and adds it to the appropriate list | |
197 | in CLASS. | |
198 | ||
199 | Unused properties on PSET are diagnosed as errors.")) | |
200 | ||
201 | (defgeneric make-sod-class-initializer | |
202 | (class nick name value-kind value-form pset &optional location) | |
203 | (:documentation | |
204 | "Construct and attach a class slot initializer, to CLASS. | |
205 | ||
206 | This is the main constructor function for class initializers. This is a | |
207 | generic function primarily so that the CLASS can intervene in the | |
208 | construction process. The default method looks up the slot using | |
209 | FIND-CLASS-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to actually | |
210 | make the initializer object, and adds it to the appropriate list in CLASS. | |
211 | ||
212 | Unused properties on PSET are diagnosed as errors.")) | |
213 | ||
214 | (defgeneric make-sod-initializer-using-slot | |
215 | (class slot init-class value-kind value-form pset location) | |
216 | (:documentation | |
217 | "Common construction protocol for slot initializers. | |
218 | ||
219 | This generic function does the common work for constructing instance and | |
220 | class initializers. It can usefully be specialized according to both the | |
221 | class and slot types. The default method uses the :LISP-CLASS property | |
222 | (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate. The | |
223 | slot is then constructed by MAKE-INSTANCE passing the arguments as | |
224 | initargs; further behaviour is left to the standard CLOS instance | |
225 | construction protocol; for example, SOD-INITIALIZER defines | |
226 | an :AFTER-method on SHARED-INITIALIZE. | |
227 | ||
228 | Diagnosing unused properties is left for the caller (usually | |
229 | MAKE-SOD-INSTANCE-INITIALIZER or MAKE-SOD-CLASS-INITIALIZER) to do. The | |
230 | caller is also expected to have set WITH-DEFAULT-ERROR-LOCATION if | |
231 | appropriate. | |
232 | ||
233 | You are not expected to call this generic function directly; it's more | |
234 | useful as a place to hang methods for custom initializer classes.")) | |
235 | ||
236 | (defmethod make-sod-instance-initializer | |
237 | ((class sod-class) nick name value-kind value-form pset | |
238 | &optional location) | |
239 | (with-default-error-location (location) | |
240 | (let* ((slot (find-instance-slot-by-name class nick name)) | |
241 | (initializer (make-sod-initializer-using-slot | |
242 | class slot 'sod-instance-initializer | |
243 | value-kind value-form pset | |
244 | (file-location location)))) | |
245 | (with-slots (instance-initializers) class | |
246 | (setf instance-initializers (append instance-initializers | |
247 | (list initializer)))) | |
248 | (check-unused-properties pset)))) | |
249 | ||
250 | (defmethod make-sod-class-initializer | |
251 | ((class sod-class) nick name value-kind value-form pset | |
252 | &optional location) | |
253 | (with-default-error-location (location) | |
254 | (let* ((slot (find-class-slot-by-name class nick name)) | |
255 | (initializer (make-sod-initializer-using-slot | |
256 | class slot 'sod-class-initializer | |
257 | value-kind value-form pset | |
258 | (file-location location)))) | |
259 | (with-slots (class-initializers) class | |
260 | (setf class-initializers (append class-initializers | |
261 | (list initializer)))) | |
262 | (check-unused-properties pset)))) | |
263 | ||
264 | (defmethod make-sod-initializer-using-slot | |
265 | ((class sod-class) (slot sod-slot) | |
266 | init-class value-kind value-form pset location) | |
267 | (make-instance (get-property pset :lisp-class :symbol init-class) | |
268 | :class class | |
269 | :slot slot | |
270 | :value-kind value-kind | |
271 | :value-form value-form | |
272 | :location location | |
273 | :pset pset)) | |
274 | ||
275 | (defmethod shared-initialize :after | |
276 | ((init sod-initializer) slot-names &key pset) | |
277 | "This method exists so that it isn't an error to provide a :PSET initarg | |
278 | to (make-instance 'sod-initializer ...). It does nothing." | |
279 | (declare (ignore slot-names pset)) | |
280 | nil) | |
281 | ||
282 | ;;;-------------------------------------------------------------------------- | |
283 | ;;; Message construction. | |
284 | ||
285 | (defgeneric make-sod-message (class name type pset &optional location) | |
286 | (:documentation | |
287 | "Construct and attach a new message with given NAME and TYPE, to CLASS. | |
288 | ||
289 | This is the main constructor function for messages. This is a generic | |
290 | function primarily so that the CLASS can intervene in the construction | |
291 | process. The default method uses the :LISP-CLASS property (defaulting to | |
292 | SOD-MESSAGE) to choose a (CLOS) class to instantiate. The message is then | |
293 | constructed by MAKE-INSTANCE passing the arguments as initargs; further | |
294 | behaviour is left to the standard CLOS instance construction protocol; for | |
295 | example, SOD-MESSAGE defines an :AFTER-method on SHARED-INITIALIZE. | |
296 | ||
297 | Unused properties on PSET are diagnosed as errors.")) | |
298 | ||
299 | (defgeneric check-message-type (message type) | |
300 | (:documentation | |
301 | "Check that TYPE is a suitable type for MESSAGE. Signal errors if not. | |
302 | ||
303 | This is separated out of SHARED-INITIALIZE, where it's called, so that it | |
304 | can be overridden conveniently by subclasses.")) | |
305 | ||
306 | (defmethod make-sod-message | |
307 | ((class sod-class) name type pset &optional location) | |
308 | (with-default-error-location (location) | |
309 | (let ((slot (make-instance (get-property pset :lisp-class :symbol | |
310 | 'sod-slot) | |
311 | :class class | |
312 | :name name | |
313 | :type type | |
314 | :location (file-location location) | |
315 | :pset pset))) | |
316 | (with-slots (slots) class | |
317 | (setf slots (append slots (list slot)))) | |
318 | (check-unused-properties pset)))) | |
319 | ||
320 | (defmethod check-message-type ((message sod-message) (type c-function-type)) | |
321 | nil) | |
322 | (defmethod check-message-type ((message sod-message) (type c-type)) | |
323 | (error "Messages must have function type, not ~A" type)) | |
324 | ||
325 | (defmethod shared-initialize :after | |
326 | ((message sod-message) slot-names &key pset) | |
327 | (declare (ignore slot-names pset)) | |
328 | (with-slots (type) message | |
329 | (check-message-type message type))) | |
330 | ||
331 | ;;;-------------------------------------------------------------------------- | |
332 | ;;; Method construction. | |
333 | ||
334 | (defgeneric make-sod-method | |
335 | (class nick name type body pset &optional location) | |
336 | (:documentation | |
337 | "Construct and attach a new method to CLASS. | |
338 | ||
339 | This is the main constructor function for methods. This is a generic | |
340 | function primarily so that the CLASS can intervene in the message lookup | |
341 | process, though this is actually a fairly unlikely occurrence. | |
342 | ||
343 | The default method looks up the message using FIND-MESSAGE-BY-NAME, | |
344 | invokes MAKE-SOD-METHOD-USING-MESSAGE to make the method object, and then | |
345 | adds the method to the class's list of methods. This split allows the | |
346 | message class to intervene in the class selection process, for example. | |
347 | ||
348 | Unused properties on PSET are diagnosed as errors.")) | |
349 | ||
350 | (defgeneric make-sod-method-using-message | |
351 | (message class type body pset location) | |
352 | (:documentation | |
353 | "Main construction subroutine for method construction. | |
354 | ||
355 | This is a generic function so that it can be specialized according to both | |
356 | a class and -- more particularly -- a message. The default method uses | |
357 | the :LISP-CLASS property (defaulting to calling CHOOSE-SOD-METHOD-CLASS) | |
358 | to choose a (CLOS) class to instantiate. The method is then constructed | |
359 | by MAKE-INSTANCE passing the arguments as initargs; further behaviour is | |
360 | left to the standard CLOS instance construction protocol; for example, | |
361 | SOD-METHOD defines an :AFTER-method on SHARED-INITIALIZE. | |
362 | ||
363 | Diagnosing unused properties is left for the caller (usually | |
364 | MAKE-SOD-METHOD) to do. The caller is also expected to have set | |
365 | WITH-DEFAULT-ERROR-LOCATION if appropriate. | |
366 | ||
367 | You are not expected to call this generic function directly; it's more | |
368 | useful as a place to hang methods for custom initializer classes.")) | |
369 | ||
370 | (defgeneric sod-message-method-class (message class pset) | |
371 | (:documentation | |
372 | "Return the preferred class for methods on MESSAGE. | |
373 | ||
374 | The message can inspect the PSET to decide on a particular message. A | |
375 | :LISP-CLASS property will usually override this decision: it's then the | |
376 | programmer's responsibility to ensure that the selected method class is | |
377 | appropriate.")) | |
378 | ||
379 | (defgeneric check-method-type (method message type) | |
380 | (:documentation | |
381 | "Check that TYPE is a suitable type for METHOD. Signal errors if not. | |
382 | ||
383 | This is separated out of SHARED-INITIALIZE, where it's called, so that it | |
384 | can be overridden conveniently by subclasses.")) | |
385 | ||
386 | (defmethod make-sod-method | |
387 | ((class sod-class) nick name type body pset &optional location) | |
388 | (with-default-error-location (location) | |
389 | (let* ((message (find-message-by-name class nick name)) | |
390 | (method (make-sod-method-using-message message class | |
391 | type body pset | |
392 | (file-location location)))) | |
393 | (with-slots (methods) class | |
394 | (setf methods (append methods (list method))))) | |
395 | (check-unused-properties pset))) | |
396 | ||
397 | (defmethod make-sod-method-using-message | |
398 | ((message sod-message) (class sod-class) type body pset location) | |
399 | (make-instance (or (get-property pset :lisp-class :symbol) | |
400 | (sod-message-method-class message class pset)) | |
401 | :message message | |
402 | :class class | |
403 | :type type | |
404 | :body body | |
405 | :location location | |
406 | :pset pset)) | |
407 | ||
408 | (defmethod sod-message-method-class | |
409 | ((message sod-message) (class sod-class) pset) | |
410 | (declare (ignore pset)) | |
411 | 'sod-method) | |
412 | ||
413 | (defmethod check-method-type | |
414 | ((method sod-method) (message sod-message) (type c-type)) | |
415 | (error "Methods must have function type, not ~A" type)) | |
416 | ||
417 | (defun arguments-lists-compatible-p (message-args method-args) | |
418 | "Compare argument lists for compatibility. | |
419 | ||
420 | Return true if METHOD-ARGS is a suitable method argument list | |
421 | corresponding to the message argument list MESSAGE-ARGS. This is the case | |
422 | if the lists are the same length, each message argument has a | |
423 | corresponding method argument with the same type, and if the message | |
424 | arguments end in an ellpisis, the method arguments must end with a | |
425 | `va_list' argument. (We can't pass actual variable argument lists around, | |
426 | except as `va_list' objects, which are devilish inconvenient things and | |
427 | require much hacking. See the method combination machinery for details.)" | |
428 | ||
429 | (and (= (length message-args) (length method-args)) | |
430 | (every (lambda (message-arg method-arg) | |
431 | (if (eq message-arg :ellipsis) | |
432 | (eq method-arg (c-type va-list)) | |
433 | (c-type-equal-p (argument-type message-arg) | |
434 | (argument-type method-arg)))) | |
435 | message-args method-args))) | |
436 | ||
437 | (defmethod check-method-type | |
438 | ((method sod-method) (message sod-message) (type c-function-type)) | |
439 | ||
440 | ;; Check compatibility. | |
441 | (with-slots ((msgtype type)) message | |
442 | (unless (c-type-equal-p type msgtype) | |
443 | (error "Method type ~A doesn't match message type ~A" type msgtype))) | |
444 | ||
445 | ;; Check that the arguments are named if we have a method body. | |
446 | (with-slots (body) method | |
447 | (unless (or (not body) | |
448 | (every #'argument-name (c-function-arguments type))) | |
449 | (error "Abstract declarators not permitted in method definitions")))) | |
450 | ||
451 | (defmethod shared-initialize :after | |
452 | ((method sod-method) slot-names &key pset) | |
453 | (declare (ignore slot-names pset)) | |
454 | (with-slots (message type) method | |
455 | (check-method-type method message type))) | |
456 | ||
457 | ;;;-------------------------------------------------------------------------- | |
458 | ;;; Bootstrapping the class graph. | |
459 | ||
460 | (defun bootstrap-classes () | |
461 | (let* ((sod-object (make-sod-class "sod_object" nil | |
462 | (make-property-set :nick 'obj))) | |
463 | (sod-class (make-sod-class "sod_class" (list sod-object) | |
464 | (make-property-set :nick 'cls))) | |
465 | (classes (list sod-object sod-class))) | |
466 | (setf (slot-value sod-class 'chained-superclass) sod-object) | |
467 | (dolist (class classes) | |
468 | (setf (slot-value class 'metaclass) sod-class)) | |
469 | (dolist (class classes) | |
470 | (finalize-sod-class class) | |
471 | (record-sod-class class)))) | |
472 | ||
473 | #| | |
474 | (defmacro define-sod-class (name superclasses &body body-and-options) | |
475 | "FIXME. This probably needs the docstring from hell." | |
476 | ||
477 | (let ((class-var (gensym "CLASS")) | |
478 | (slots-var (gensym "SLOTS")) | |
479 | (inst-inits-var (gensym "INST-INITS")) | |
480 | (class-inits-var (gensym "CLASS-INITS")) | |
481 | (messages-var (gensym "MESSAGES")) | |
482 | (methods-var (gensym "METHODS"))) | |
483 | |# | |
484 | ||
485 | ;;;----- That's all, folks -------------------------------------------------- |