Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Basic definitions for classes, methods and suchlike | |
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 | ;;; Class definitions. | |
30 | ||
31 | (defclass sod-class () | |
32 | ((name :initarg :name | |
33 | :type string | |
34 | :reader sod-class-name) | |
35 | (location :initarg :location | |
36 | :initform (file-location nil) | |
37 | :type file-location | |
38 | :reader file-location) | |
39 | (nickname :initarg :nick | |
40 | :type string | |
41 | :reader sod-class-nickname) | |
42 | (direct-superclasses :initarg :superclasses | |
43 | :type list | |
44 | :reader sod-class-direct-superclasses) | |
45 | (chained-superclass :initarg :chain-to | |
46 | :type (or sod-class null) | |
47 | :reader sod-class-chained-superclass) | |
48 | (metaclass :initarg :metaclass | |
49 | :type sod-class | |
50 | :reader sod-class-metaclass) | |
51 | (slots :initarg :slots | |
52 | :type list | |
53 | :initform nil | |
54 | :accessor sod-class-slots) | |
55 | (instance-initializers :initarg :instance-initializers | |
56 | :type list | |
57 | :initform nil | |
58 | :accessor sod-class-instance-initializers) | |
59 | (class-initializers :initarg :class-initializers | |
60 | :type list | |
61 | :initform nil | |
62 | :accessor sod-class-class-initializers) | |
63 | (messages :initarg :messages | |
64 | :type list | |
65 | :initform nil | |
66 | :accessor sod-class-messages) | |
67 | (methods :initarg :methods | |
68 | :type list | |
69 | :initform nil | |
70 | :accessor sod-class-methods) | |
71 | ||
72 | (class-precedence-list :type list :accessor sod-class-precedence-list) | |
73 | ||
74 | (chain-head :type sod-class :accessor sod-class-chain-head) | |
75 | (chain :type list :accessor sod-class-chain) | |
76 | (chains :type list :accessor sod-class-chains) | |
77 | ||
78 | (state :initform nil | |
79 | :type (member nil :finalized broken) | |
80 | :accessor sod-class-state)) | |
81 | (:documentation | |
82 | "Classes describe the layout and behaviour of objects. | |
83 | ||
84 | The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAINED-SUPERCLASS and | |
85 | METACLASS slots are intended to be initialized when the class object is | |
86 | constructed: | |
87 | ||
88 | * The NAME is the identifier associated with the class in the user's | |
89 | source file. It is used verbatim in the generated C code as a type | |
90 | name, and must be distinct from other file-scope names in any source | |
91 | file which includes the class definition. Furthermore, other names | |
92 | are derived from the class name (most notably the class object | |
93 | NAME__class), which have external linkage and must therefore be | |
94 | distinct from all other identifiers in the program. It is forbidden | |
95 | for a class NAME to begin with an underscore or to contain two | |
96 | consecutive underscores. | |
97 | ||
98 | * The LOCATION identifies where in the source the class was defined. It | |
99 | gets used in error messages. | |
100 | ||
101 | * The NICKNAME is a shorter identifier used to name the class in some | |
102 | circumstances. The uniqueness requirements on NICKNAME are less | |
103 | strict, which allows them to be shorter: no class may have two classes | |
104 | with the same nickname on its class precedence list. Nicknames are | |
105 | used (user-visibly) to distinguish slots and messages defined by | |
106 | different classes, and (invisibly) in the derived names of direct | |
107 | methods. It is forbidden for a nickname to begin with an underscore, | |
108 | or to contain two consecutive underscores. | |
109 | ||
110 | * The DIRECT-SUPERCLASSES are a list of the class's direct superclasses, | |
111 | in the order that they were declared in the source. The class | |
112 | precedence list is computed from the DIRECT-SUPERCLASSES lists of all | |
113 | of the superclasses involved. | |
114 | ||
115 | * The CHAINED-SUPERCLASS is either NIL or one of the | |
116 | DIRECT-SUPERCLASSES. Class chains are a means for recovering most of | |
117 | the benefits of simple hierarchy lost by the introduction of multiple | |
118 | inheritance. A class's superclasses (including itself) are | |
119 | partitioned into chains, consisting of a class, its CHAINED- | |
120 | SUPERCLASS, that class's CHAINED-SUPERCLASS, and so on. It is an | |
121 | error if two direct subclasses of any class appear in the same | |
122 | chain (a global property which requires global knowledge of an entire | |
123 | program's class hierarchy in order to determine sensibly). Slots of | |
124 | superclasses in the same chain can be accessed efficiently; there is | |
125 | an indirection needed to access slots of superclasses in other chains. | |
126 | Furthermore, an indirection is required to perform a cross-chain | |
127 | conversion (i.e., converting a pointer to an instance of some class | |
128 | into a pointer to an instance of one of its superclasses in a | |
129 | different chain), an operation which occurs implicitly in effective | |
130 | methods in order to call direct methods defined on cross-chain | |
131 | superclasses. | |
132 | ||
133 | * The METACLASS is the class of the class object. Classes are objects | |
134 | in their own right, and therefore must be instances of some class; | |
135 | this class is the metaclass. Metaclasses can define additional slots | |
136 | and methods to be provided by their instances; a class definition can | |
137 | provide (C constant expression) initial values for the metaclass | |
138 | instance. | |
139 | ||
140 | The next few slots can't usually be set at object-construction time, since | |
141 | the objects need to contain references to the class object itself. | |
142 | ||
143 | * The SLOTS are a list of the slots defined by the class (instances of | |
144 | SOD-SLOT). (The class will also define all of the slots defined by | |
145 | its superclasses.) | |
146 | ||
147 | * The INSTANCE-INITIALIZERS and CLASS-INITIALIZERS are lists of | |
148 | initializers for slots (see SOD-INITIALIZER and subclasses), providing | |
149 | initial values for instances of the class, and for the class's class | |
150 | object itself, respectively. | |
151 | ||
152 | * The MESSAGES are a list of the messages recognized by the class | |
153 | (instances of SOD-MESSAGE and subclasses). (Note that the message | |
154 | need not have any methods defined on it. The class will also | |
155 | recognize all of the messages defined by its superclasses.) | |
156 | ||
157 | * The METHODS are a list of (direct) methods defined on the class | |
158 | (instances of SOD-METHOD and subclasses). Each method provides | |
159 | behaviour to be invoked by a particular message recognized by the | |
160 | class. | |
161 | ||
162 | Other slots are computed from these in order to describe the class's | |
163 | layout and effective methods; this is done by FINALIZE-SOD-CLASS. | |
164 | ||
165 | FIXME: Add the necessary slots and describe them.")) | |
166 | ||
167 | (defmethod print-object ((class sod-class) stream) | |
168 | (print-unreadable-object (class stream :type t) | |
169 | (prin1 (sod-class-name class) stream))) | |
170 | ||
171 | (defclass sod-message () | |
172 | ((name :initarg :name | |
173 | :type string | |
174 | :reader sod-message-name) | |
175 | (location :initarg :location | |
176 | :initform (file-location nil) | |
177 | :type file-location | |
178 | :reader file-location) | |
179 | (class :initarg :class | |
180 | :type sod-class | |
181 | :reader sod-message-class) | |
182 | (type :initarg :type | |
183 | :type c-function-type | |
184 | :reader sod-message-type)) | |
185 | (:documentation | |
186 | "Messages the means for stimulating an object to behave. | |
187 | ||
188 | SOD is a single-dispatch object system, like Smalltalk, C++, Python and so | |
189 | on, but unlike CLOS and Dylan. Behaviour is invoked by `sending messages' | |
190 | to objects. A message carries a name (distinguishing it from other | |
191 | messages recognized by the same class), and a number of arguments; the | |
192 | object may return a value in response. Sending a message therefore looks | |
193 | very much like calling a function; indeed, each message bears the static | |
194 | TYPE signature of a function. | |
195 | ||
196 | An object reacts to being sent a message by executing an `effective | |
197 | method', constructed from the direct methods defined on the recpient's | |
198 | (run-time, not necessarily statically-declared) class and its superclasses | |
199 | according to the message's `method combination'. | |
200 | ||
201 | Much interesting work is done by subclasses of SOD-MESSAGE, which (for | |
202 | example) specify method combinations. | |
203 | ||
204 | The slots are as follows. | |
205 | ||
206 | * The NAME distinguishes the message from others defined by the same | |
207 | class. Unlike most (all?) other object systems, messages defined in | |
208 | different classes are in distinct namespaces. It is forbidden for a | |
209 | message name to begin with an underscore, or to contain two | |
210 | consecutive underscores. (Final underscores are fine.) | |
211 | ||
212 | * The LOCATION states where in the user's source the slot was defined. | |
213 | It gets used in error messages. | |
214 | ||
215 | * The CLASS states which class defined the message. | |
216 | ||
217 | * The TYPE is a function type describing the message's arguments and | |
218 | return type. | |
219 | ||
220 | Subclasses can (and probably will) define additional slots.")) | |
221 | ||
222 | (defclass sod-method () | |
223 | ((message :initarg :message | |
224 | :type sod-message | |
225 | :reader sod-method-message) | |
226 | (location :initarg :location | |
227 | :initform (file-location nil) | |
228 | :type file-location | |
229 | :reader file-location) | |
230 | (class :initarg :class | |
231 | :type sod-class | |
232 | :reader sod-method-class) | |
233 | (type :initarg :type | |
234 | :type c-function-type | |
235 | :reader sod-method-type) | |
236 | (body :initarg :body | |
237 | :type (or c-fragment null) | |
238 | :reader sod-method-body)) | |
239 | (:documentation | |
240 | "(Direct) methods are units of behaviour. | |
241 | ||
242 | Methods are the unit of behaviour in SOD. Classes define direct methods | |
243 | for particular messages. | |
244 | ||
245 | When a message is received by an instance, all of the methods defined for | |
246 | that message on that instance's (run-time, not static) class and its | |
247 | superclasses are `applicable'. The applicable methods are gathered | |
248 | together and invoked in some way; the details of this are left to the | |
249 | `method combination', determined by the subclass of SOD-MESSAGE. | |
250 | ||
251 | The slots are as follows. | |
252 | ||
253 | * The MESSAGE describes which meessage invokes the method's behaviour. | |
254 | The method is combined with other methods on the same message | |
255 | according to the message's method combination, to form an `effective | |
256 | method'. | |
257 | ||
258 | * The LOCATION states where, in the user's source, the method was | |
259 | defined. This gets used in error messages. (Depending on the user's | |
260 | coding style, this location might be subtly different from the BODY's | |
261 | location.) | |
262 | ||
263 | * The CLASS specifies which class defined the method. This will be | |
264 | either the class of the message, or one of its descendents. | |
265 | ||
266 | * The TYPE gives the type of the method, including its arguments. This | |
267 | will, in general, differ from the type of the message for several | |
268 | reasons. | |
269 | ||
270 | -- Firstly, the method type must include names for all of the | |
271 | method's parameters. The message definition can omit the | |
272 | parameter names (in the same way as a function declaration can). | |
273 | Formally, the message definition can contain abstract | |
274 | declarators, whereas method definitions must not. | |
275 | ||
276 | -- Method combinations may require different parameter or return | |
277 | types. For example, `before' and `after' methods don't | |
278 | contribute to the message's return value, so they must be defined | |
279 | as returning `void'. | |
280 | ||
281 | -- Method combinations may permit methods whose parameter and/or | |
282 | return types don't exactly match the corresponding types of the | |
283 | message. For example, one might have methods with covariant | |
284 | return types and contravariant parameter types. (This sounds | |
285 | nice, but it doesn't actually seem like such a clever idea when | |
286 | you consider that the co-/contravariance must hold among all the | |
287 | applicable methods ordered according to the class precedence | |
288 | list. As a result, a user might have to work hard to build | |
289 | subclasses whose CPLs match the restrictions implied by the | |
290 | method types.) | |
291 | ||
292 | Method objects are fairly passive in the SOD translator. However, | |
293 | subclasses of SOD-MESSAGE may (and probably will) construct instances of | |
294 | subclasses of SOD-METHOD in order to carry the additional metadata they | |
295 | need to keep track of.")) | |
296 | ||
297 | (defclass sod-slot () | |
298 | ((name :initarg :name | |
299 | :type string | |
300 | :reader sod-slot-name) | |
301 | (location :initarg :location | |
302 | :initform (file-location nil) | |
303 | :type file-location | |
304 | :reader file-location) | |
305 | (class :initarg :class | |
306 | :type sod-class | |
307 | :reader sod-slot-class) | |
308 | (type :initarg :type | |
309 | :type c-type | |
310 | :reader sod-slot-type)) | |
311 | (:documentation | |
312 | "Slots are units of information storage in instances. | |
313 | ||
314 | Each class defines a number of slots, which function similarly to (data) | |
315 | members in structures. An instance contains all of the slots defined in | |
316 | its class and all of its superclasses. | |
317 | ||
318 | A slot carries the following information. | |
319 | ||
320 | * A NAME, which distinguishes it from other slots defined by the same | |
321 | class. Unlike most (all?) other object systems, slots defined in | |
322 | different classes are in distinct namespaces. There are no special | |
323 | restrictions on slot names. | |
324 | ||
325 | * A LOCATION, which states where in the user's source the slot was | |
326 | defined. This gets used in error messages. | |
327 | ||
328 | * A CLASS, which states which class defined the slot. The slot is | |
329 | available in instances of this class and all of its descendents. | |
330 | ||
331 | * A TYPE, which is the C type of the slot. This must be an object type | |
332 | (certainly not a function type, and it must be a complete type by the | |
333 | time that the user header code has been scanned).")) | |
334 | ||
335 | (defclass sod-initializer () | |
336 | ((slot :initarg :slot | |
337 | :type sod-slot | |
338 | :reader sod-initializer-slot) | |
339 | (location :initarg :location | |
340 | :initform (file-location nil) | |
341 | :type file-location | |
342 | :reader file-location) | |
343 | (class :initarg :class | |
344 | :type sod-class | |
345 | :reader sod-initializer-clas) | |
346 | (value-kind :initarg :value-kind | |
347 | :type keyword | |
348 | :reader sod-initializer-value-kind) | |
349 | (value-form :initarg :value-form | |
350 | :type c-fragment | |
351 | :reader sod-initializer-value-form)) | |
352 | (:documentation | |
353 | "Provides an initial value for a slot. | |
354 | ||
355 | The slots of an initializer are as follows. | |
356 | ||
357 | * The SLOT specifies which slot this initializer is meant to initialize. | |
358 | ||
359 | * The LOCATION states the position in the user's source file where the | |
360 | initializer was found. This gets used in error messages. (Depending | |
361 | on the source layout style, this might differ from the location in the | |
362 | VALUE-FORM C fragment.) | |
363 | ||
364 | * The CLASS states which class defined this initializer. For instance | |
365 | slot initializers (SOD-INSTANCE-INITIALIZER), this will be the same as | |
366 | the SLOT's class, or be one of its descendants. For class slot | |
367 | initializers (SOD-CLASS-INITIALIZER), this will be an instance of the | |
368 | SLOT's class, or an instance of one of its descendants. | |
369 | ||
370 | * The VALUE-KIND states what manner of initializer we have. It can be | |
371 | either :SINGLE, indicating a standalone expression, or :COMPOUND, | |
372 | indicating a compound initializer which must be surrounded by braces | |
373 | on output. | |
374 | ||
375 | * The VALUE-FORM gives the text of the initializer, as a C fragment. | |
376 | ||
377 | Typically you'll see instances of subclasses of this class in the wild | |
378 | rather than instances of this class directly. See SOD-CLASS-INITIALIZER | |
379 | and SOD-INSTANCE-INITIALIZER.")) | |
380 | ||
381 | (defclass sod-class-initializer (sod-initializer) | |
382 | () | |
383 | (:documentation | |
384 | "Provides an initial value for a class slot. | |
385 | ||
386 | A class slot initializer provides an initial value for a slot in the class | |
387 | object (i.e., one of the slots defined by the class's metaclass). Its | |
388 | VALUE-FORM must have the syntax of an initializer, and its consituent | |
389 | expressions must be constant expressions. | |
390 | ||
391 | See SOD-INITIALIZER for more details.")) | |
392 | ||
393 | (defclass sod-instance-initializer (sod-initializer) | |
394 | () | |
395 | (:documentation | |
396 | "Provides an initial value for a slot in all instances. | |
397 | ||
398 | An instance slot initializer provides an initial value for a slot in | |
399 | instances of the class. Its VALUE-FORM must have the syntax of an | |
400 | initializer. Furthermore, if the slot has aggregate type, then you'd | |
401 | better be sure that your compiler supports compound literals (6.5.2.5) | |
402 | because that's what the initializer gets turned into. | |
403 | ||
404 | See SOD-INITIALIZER for more details.")) | |
405 | ||
406 | ;;;-------------------------------------------------------------------------- | |
407 | ;;; Classes as C types. | |
408 | ||
409 | (defclass c-class-type (simple-c-type) | |
410 | ((class :initarg :class | |
411 | :type (or null sod-class) | |
412 | :accessor c-type-class)) | |
413 | (:documentation | |
414 | "A SOD class, as a C type. | |
415 | ||
416 | One usually handles classes as pointers, but the type refers to the actual | |
417 | instance structure itself. Or, in fact, just the primary chain of the | |
418 | instance (i.e., the one containing the class's own direct slots) -- which | |
419 | is why dealing with the instance structure directly doesn't make much | |
420 | sense. | |
421 | ||
422 | The CLASS slot will be NIL if the class isn't defined yet, i.e., this | |
423 | entry was constructed by a forward reference operation. | |
424 | ||
425 | The NAME slot inherited from SIMPLE-C-TYPE is here so that we can print | |
426 | the type even when it's a forward reference.")) | |
427 | ||
428 | (defmethod c-type-equal-p and ((type-a c-class-type) | |
429 | (type-b c-class-type)) | |
430 | (eql (c-type-class type-a) (c-type-class type-b))) | |
431 | ||
432 | (defmethod print-c-type (stream (type c-class-type) &optional colon atsign) | |
433 | (declare (ignore colon atsign)) | |
434 | (format stream "~:@<CLASS ~@_~S~:>" (c-type-name type))) | |
435 | ||
436 | (defun find-class-type (name &optional floc) | |
437 | "Look up NAME and return the corresponding C-CLASS-TYPE. | |
438 | ||
439 | Returns two values: TYPE and WINP. | |
440 | ||
441 | * If the type was found, and was a class, returns TYPE. | |
442 | ||
443 | * If no type was found at all, returns NIL. | |
444 | ||
445 | * If a type was found, but it wasn't a class, signals an error at FLOC." | |
446 | ||
447 | (with-default-error-location (floc) | |
448 | (let ((type (gethash name *type-map*))) | |
449 | (typecase type | |
450 | (null nil) | |
451 | (c-class-type type) | |
452 | (t (error "Type `~A' (~A) is not a class" name type)))))) | |
453 | ||
454 | (defun make-class-type (name &optional floc) | |
455 | "Return a class type for NAME, creating it if necessary. | |
456 | ||
457 | FLOC is the location to use in error reports." | |
458 | (multiple-value-bind (type winp) (find-class-type name floc) | |
459 | (cond ((not winp) nil) | |
460 | (type type) | |
461 | (t (setf (gethash name *type-map*) | |
462 | (make-instance 'c-class-type :name name :class nil)))))) | |
463 | ||
464 | (defun find-sod-class (name &optional floc) | |
465 | "Return the SOD-CLASS object with the given NAME. | |
466 | ||
467 | FLOC is the location to use in error reports." | |
468 | (with-default-error-location (floc) | |
469 | (multiple-value-bind (type winp) (find-class-type name floc) | |
470 | (cond ((not type) (error "Type `~A' not known" name)) | |
471 | (t (let ((class (c-type-class type))) | |
472 | (unless class | |
473 | (error "Class `~A' is incomplete" name)) | |
474 | class)))))) | |
475 | ||
476 | (defun record-sod-class (class &optional (floc class)) | |
477 | "Record CLASS as being a class definition. | |
478 | ||
479 | FLOC is the location to use in error reports." | |
480 | (with-default-error-location (floc) | |
481 | (let* ((name (sod-class-name class)) | |
482 | (type (make-class-type name floc))) | |
483 | (cond ((null type) nil) | |
484 | ((c-type-class type) | |
485 | (cerror* "Class `~A' already defined at ~A" | |
486 | name (file-location (c-type-class type)))) | |
487 | (t | |
488 | (setf (c-type-class type) class)))))) | |
489 | ||
490 | (define-c-type-syntax class (name) | |
491 | "Returns a type object for the named class." | |
492 | (make-class-type (c-name-case name))) | |
493 | ||
494 | ;;;-------------------------------------------------------------------------- | |
495 | ;;; Class finalization. | |
496 | ||
497 | ;; Protocol. | |
498 | ||
499 | (defgeneric compute-chains (class) | |
500 | (:documentation | |
501 | "Compute the layout chains for CLASS. | |
502 | ||
503 | Fills in | |
504 | ||
505 | * the head of the class's primary chain; | |
506 | ||
507 | * the class's primary chain as a list, most- to least-specific; and | |
508 | ||
509 | * the complete collection of chains, as a list of lists, each most- to | |
510 | least-specific, with the primary chain first. | |
511 | ||
512 | If the chains are ill-formed (i.e., not distinct) then an error is | |
513 | reported and the function returns nil; otherwise it returns a true | |
514 | value.")) | |
515 | ||
516 | (defgeneric check-sod-class (class) | |
517 | (:documentation | |
518 | "Check the CLASS for validity. | |
519 | ||
520 | This is done as part of class finalization. The checks performed are as | |
521 | follows. | |
522 | ||
523 | * The class name and nickname, and the names of messages, obey the | |
524 | rules (see VALID-NAME-P). | |
525 | ||
526 | * The messages and slots have distinct names. | |
527 | ||
528 | * The classes in the class-precedence-list have distinct nicknames. | |
529 | ||
530 | * The chained-superclass is actually one of the direct superclasses. | |
531 | ||
532 | * The chosen metaclass is actually a subclass of all of the | |
533 | superclasses' metaclasses. | |
534 | ||
535 | Returns true if all is well; false (and signals errors) if anything was | |
536 | wrong.")) | |
537 | ||
538 | (defgeneric finalize-sod-class (class) | |
539 | (:documentation | |
540 | "Computes all of the gory details about a class. | |
541 | ||
542 | Once one has stopped inserting methods and slots and so on into a class, | |
543 | one needs to finalize it to determine the layout structure and the class | |
544 | precedence list and so on. More precisely that gets done is this: | |
545 | ||
546 | * Related classes (i.e., direct superclasses and the metaclass) are | |
547 | finalized if they haven't been already. | |
548 | ||
549 | * If you've been naughty and failed to store a list of slots or | |
550 | whatever, then an empty list is inserted. | |
551 | ||
552 | * The class precedence list is computed and stored. | |
553 | ||
554 | * The class is checked for compiance with the well-formedness rules. | |
555 | ||
556 | * The layout chains are computed. | |
557 | ||
558 | Other stuff will need to happen later, but it's not been done yet. In | |
559 | particular: | |
560 | ||
561 | * Actually computing the layout of the instance and the virtual tables. | |
562 | ||
563 | * Combining the applicable methods into effective methods. | |
564 | ||
565 | FIXME this needs doing.")) | |
566 | ||
567 | ;; Implementation. | |
568 | ||
569 | (defmethod compute-chains ((class sod-class)) | |
570 | (with-default-error-location (class) | |
571 | (let* ((head (with-slots (chained-superclass) class | |
572 | (if chained-superclass | |
573 | (sod-class-chain-head chained-superclass) | |
574 | class))) | |
575 | (chain (with-slots (chained-superclass) class | |
576 | (cons class (and chained-superclass | |
577 | (sod-class-chain chained-superclass))))) | |
578 | (chains (list chain))) | |
579 | ||
580 | ;; Compute the chains. This is (unsurprisingly) the hard bit. The | |
581 | ;; chain of this class must either be a new chain or the same as one of | |
582 | ;; its superclasses. Therefore, the chains are well-formed if the | |
583 | ;; chains of the superclasses are distinct. We can therefore scan the | |
584 | ;; direct superclasses from left to right as follows. | |
585 | (with-slots (direct-superclasses) class | |
586 | (let ((table (make-hash-table))) | |
587 | (dolist (super direct-superclasses) | |
588 | (let* ((head (sod-class-chain-head super)) | |
589 | (tail (gethash head table))) | |
590 | (cond ((not tail) | |
591 | (setf (gethash head table) super)) | |
592 | ((not (sod-subclass-p super tail)) | |
593 | (error "Conflicting chains (~A and ~A) in class ~A" | |
594 | (sod-class-name tail) | |
595 | (sod-class-name super) | |
596 | (sod-class-name class))) | |
597 | (t | |
598 | (let ((ch (sod-class-chain super))) | |
599 | (unless (eq ch chain) | |
600 | (push ch chains))))))))) | |
601 | ||
602 | ;; Done. | |
603 | (values head chain (nreverse chains))))) | |
604 | ||
605 | (defmethod check-sod-class ((class sod-class)) | |
606 | (with-default-error-location (class) | |
607 | ||
608 | ;; Check the names of things are valid. | |
609 | (with-slots (name nickname messages) class | |
610 | (unless (valid-name-p name) | |
611 | (error "Invalid class name `~A'" name)) | |
612 | (unless (valid-name-p nickname) | |
613 | (error "Invalid class nickname `~A' on class `~A'" nickname name)) | |
614 | (dolist (message messages) | |
615 | (unless (valid-name-p (sod-message-name message)) | |
616 | (error "Invalid message name `~A' on class `~A'" | |
617 | (sod-message-name message) name)))) | |
618 | ||
619 | ;; Check that the slots and messages have distinct names. | |
620 | (with-slots (name slots messages class-precedence-list) class | |
621 | (flet ((check-list (list what namefunc) | |
622 | (let ((table (make-hash-table :test #'equal))) | |
623 | (dolist (item list) | |
624 | (let ((itemname (funcall namefunc item))) | |
625 | (if (gethash itemname table) | |
626 | (error "Duplicate ~A name `~A' on class `~A'" | |
627 | what itemname name) | |
628 | (setf (gethash itemname table) item))))))) | |
629 | (check-list slots "slot" #'sod-slot-name) | |
630 | (check-list messages "message" #'sod-message-name) | |
631 | (check-list class-precedence-list "nickname" #'sod-class-name))) | |
632 | ||
633 | ;; Check that the CHAIN-TO class is actually a superclass. | |
634 | (with-slots (name direct-superclasses chained-superclass) class | |
635 | (unless (or (not chained-superclass) | |
636 | (member chained-superclass direct-superclasses)) | |
637 | (error "In `~A~, chain-to class `~A' is not a direct superclass" | |
638 | name (sod-class-name chained-superclass)))) | |
639 | ||
640 | ;; Check that the metaclass is a subclass of each of the | |
641 | ;; superclasses' metaclasses. | |
642 | (with-slots (name metaclass direct-superclasses) class | |
643 | (dolist (super direct-superclasses) | |
644 | (unless (sod-subclass-p metaclass (sod-class-metaclass super)) | |
645 | (error "Incompatible metaclass for `~A': ~ | |
646 | `~A' isn't subclass of `~A' (of `~A')" | |
647 | name | |
648 | (sod-class-name metaclass) | |
649 | (sod-class-name (sod-class-metaclass super)) | |
650 | (sod-class-name super))))))) | |
651 | ||
652 | (defmethod finalize-sod-class ((class sod-class)) | |
653 | (with-default-error-location (class) | |
654 | (ecase (sod-class-state class) | |
655 | ((nil) | |
656 | ||
657 | ;; If this fails, mark the class as a loss. | |
658 | (setf (sod-class-state class) :broken) | |
659 | ||
660 | ;; Finalize all of the superclasses. There's some special pleading | |
661 | ;; here to make bootstrapping work: we don't try to finalize the | |
662 | ;; metaclass if we're a root class (no direct superclasses -- because | |
663 | ;; in that case the metaclass will have to be a subclass of us!), or | |
664 | ;; if it's equal to us. This is enough to tie the knot at the top of | |
665 | ;; the class graph. | |
666 | (with-slots (name direct-superclasses metaclass) class | |
667 | (dolist (super direct-superclasses) | |
668 | (finalize-sod-class super)) | |
669 | (unless (or (null direct-superclasses) | |
670 | (eq class metaclass)) | |
671 | (finalize-sod-class metaclass))) | |
672 | ||
673 | ;; Clobber the lists of items if they've not been set. | |
674 | (dolist (slot '(slots instance-initializers class-initializers | |
675 | messages methods)) | |
676 | (unless (slot-boundp class slot) | |
677 | (setf (slot-value class slot) nil))) | |
678 | ||
679 | ;; If the CPL hasn't been done yet, compute it. | |
680 | (with-slots (class-precedence-list) class | |
681 | (unless (slot-boundp class 'class-precedence-list) | |
682 | (setf class-precedence-list (compute-cpl class)))) | |
683 | ||
684 | ;; If no metaclass has been established, then choose one. | |
685 | (with-slots (metaclass) class | |
686 | (unless (and (slot-boundp class 'metaclass) metaclass) | |
687 | (setf metaclass (guess-metaclass class)))) | |
688 | ||
689 | ;; If no nickname has been set, choose a default. This might cause | |
690 | ;; conflicts, but, well, the user should have chosen an explicit | |
691 | ;; nickname. | |
692 | (with-slots (name nickname) class | |
693 | (unless (and (slot-boundp class 'nickname) nickname) | |
694 | (setf nickname (string-downcase name)))) | |
695 | ||
696 | ;; Check that the class is fairly sane. | |
697 | (check-sod-class class) | |
698 | ||
699 | ;; Determine the class's layout. | |
700 | (compute-chains class) | |
701 | ||
702 | ;; Done. | |
703 | (setf (sod-class-state class) :finalized) | |
704 | t) | |
705 | ||
706 | (:broken | |
707 | nil) | |
708 | ||
709 | (:finalized | |
710 | t)))) | |
711 | ||
712 | ;;;----- That's all, folks -------------------------------------------------- |