3 ;;; Class finalization implementation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
29 ;;; Class precedence lists.
31 ;; Just for fun, we implement a wide selection of precedence list algorithms.
32 ;; C3 seems to be clearly the best, with fewer sharp edges for the unwary.
34 ;; The extended precedence graph (EPG) is constructed by adding edges to the
35 ;; superclass graph. If A and B are classes, then write A < B if A is a
36 ;; (maybe indirect) subclass of B. For every two classes A and B, and for
37 ;; every /maximal/ subclass of both A and B (i.e., every C for which C < A
38 ;; and C < B, but there does not exist D such that D < A, D < B and C < D):
39 ;; if A precedes B in C's direct superclass list, then draw an edge A -> B,
40 ;; otherwise draw the edge B -> A.
42 ;; A linearization respects the EPG if, whenever A precedes B in the
43 ;; linearization, there is a path from A to B. The EPG can be cyclic; in
44 ;; that case, we don't care which order the classes in the cycle are
47 ;; See Barrett, Cassels, Haahr, Moon, Playford, Withington, `A Monotonic
48 ;; Superclass Linearization for Dylan' for more detail.
49 ;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
53 (export 'merge-class-lists)
54 (defun merge-class-lists (lists pick)
55 "Merge the LISTS of classes, using PICK to break ties.
57 This is a convenience wrapper around the main `merge-lists' function.
58 Given that class linearizations (almost?) always specify a custom
59 tiebreaker function, this isn't a keyword argument. Also, this wrapper
60 provides a standard presentation function so that any errors are presented
64 :present (lambda (class)
65 (format nil "`~A'" (sod-class-name class)))))
67 ;;; Tiebreaker functions.
69 (defun clos-tiebreaker (candidates so-far)
70 "The CLOS linearization tiebreaker function.
72 Intended for use with `merge-lists'. Returns the member of CANDIDATES
73 which has a direct subclass furthest to the right in the list SO-FAR.
75 This must disambiguate. The SO-FAR list cannot be empty, since the class
76 under construction precedes all of the others. If two classes share a
77 direct subclass then that subclass's direct superclasses list must order
78 them relative to each other."
81 (dolist (class so-far)
82 (dolist (candidate candidates)
83 (when (member candidate (sod-class-direct-superclasses class))
84 (setf winner candidate))))
86 (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
89 (defun c3-tiebreaker (candidates cpls)
90 "The C3 linearization tiebreaker function.
92 Intended for use with `merge-lists'. Returns the member of CANDIDATES
93 which appears in the earliest element of CPLS, which should be the list of
94 the class precedence lists of the direct superclasses of the class in
95 question, in the order specified in the class declaration.
97 The only class in the class precedence list which does not appear in one
98 of these lists is the new class itself, which must precede all of the
101 This must disambiguate, since if two classes are in the same class
102 precedence list, then one must appear in it before the other, which
103 provides an ordering between them. (In this situation we return the one
104 that matches earliest anyway, which would still give the right answer.)
106 Note that this will merge the CPLs of superclasses /as they are/, not
107 necessarily as C3 would have computed them. This ensures monotonicity
108 assuming that the superclass CPLs are already monotonic. If they aren't,
109 you're going to lose anyway."
112 (dolist (candidate candidates)
113 (when (member candidate cpl)
114 (return-from c3-tiebreaker candidate))))
115 (error "SOD INTERNAL ERROR: Failed to break tie in C3"))
117 ;;; Linearization functions.
120 (defun clos-cpl (class)
121 "Compute the class precedence list of CLASS using CLOS linearization rules.
123 We merge the direct-superclass lists of all of CLASS's superclasses,
124 disambiguating using `clos-tiebreaker'.
126 The CLOS linearization preserves local class ordering, but is not
127 monotonic, and does not respect the extended precedence graph. CLOS
128 linearization will succeed whenever Dylan or C3 linearization succeeds;
129 the converse is not true."
131 (labels ((superclasses (class)
132 (let ((direct-supers (sod-class-direct-superclasses class)))
133 (remove-duplicates (cons class
134 (mappend #'superclasses
137 (mapcar (lambda (class)
138 (cons class (sod-class-direct-superclasses class)))
139 (superclasses class))
143 (defun dylan-cpl (class)
144 "Compute the class precedence list of CLASS using Dylan linearization
147 We merge the direct-superclass list of CLASS with the full class
148 precedence lists of its direct superclasses, disambiguating using
149 `clos-tiebreaker'. (Inductively, these lists will be consistent with the
150 CPLs of indirect superclasses, since those CPLs' orderings are reflected
151 in the CPLs of the direct superclasses.)
153 The Dylan linearization preserves local class ordering and is monotonic,
154 but does not respect the extended precedence graph.
156 Note that this will merge the CPLs of superclasses /as they are/, not
157 necessarily as Dylan would have computed them. This ensures monotonicity
158 assuming that the superclass CPLs are already monotonic. If they aren't,
159 you're going to lose anyway."
161 (let ((direct-supers (sod-class-direct-superclasses class)))
163 (cons (cons class direct-supers)
164 (mapcar #'sod-class-precedence-list direct-supers))
168 (defun c3-cpl (class)
169 "Compute the class precedence list of CLASS using C3 linearization rules.
171 We merge the direct-superclass list of CLASS with the full class
172 precedence lists of its direct superclasses, disambiguating using
175 The C3 linearization preserves local class ordering, is monotonic, and
176 respects the extended precedence graph. It is the linearization used in
177 Python, Perl 6 and other languages. It is the recommended linearization
180 (let* ((direct-supers (sod-class-direct-superclasses class))
181 (cpls (mapcar #'sod-class-precedence-list direct-supers)))
182 (merge-class-lists (cons (cons class direct-supers) cpls)
183 (lambda (candidates so-far)
184 (declare (ignore so-far))
185 (c3-tiebreaker candidates cpls)))))
187 (export 'flavors-cpl)
188 (defun flavors-cpl (class)
189 "Compute the class precedence list of CLASS using Flavors linearization
192 We do a depth-first traversal of the superclass graph, ignoring duplicates
193 of classes we've already visited. Interestingly, this has the property of
194 being able to tolerate cyclic superclass graphs, though defining cyclic
195 graphs is syntactically impossible in SOD.
197 This linearization has few other redeeming features, however. In
198 particular, the top class tends not to be at the end of the CPL, despite
199 it being unequivocally less specific than any other class."
202 (labels ((walk (class)
203 (unless (member class done)
205 (dolist (super (sod-class-direct-superclasses class))
211 (defun python-cpl (class)
212 "Compute the class precedence list of CLASS using the documented Python 2.2
215 We do a depth-first traversal of the superclass graph, retaining only the
216 last occurrence of each class visited.
218 This linearization has few redeeming features. It was never actually
219 implemented; the true Python 2.2 linearization seems closer to (but
220 different from) L*LOOPS."
223 (labels ((walk (class)
225 (dolist (super (sod-class-direct-superclasses class))
228 (delete-duplicates (nreverse done)))))
230 (export 'l*loops-cpl)
231 (defun l*loops-cpl (class)
232 "Compute the class precedence list of CLASS using L*LOOPS linearization
235 We merge the class precedence lists of the direct superclasses of CLASS,
236 disambiguating by choosing the earliest candidate which appears in a
237 depth-first walk of the superclass graph.
239 The L*LOOPS rules are monotonic and respect the extended precedence
240 graph. However (unlike Dylan and CLOS) they don't respect local
241 precedence order i.e., the direct-superclasses list orderings."
243 (let ((dfs (flavors-cpl class)))
245 (merge-class-lists (mapcar #'sod-class-precedence-list
246 (sod-class-direct-superclasses class))
247 (lambda (candidates so-far)
248 (declare (ignore so-far))
250 (when (member class candidates)
251 (return class))))))))
253 ;;; Default function.
255 (defmethod compute-cpl ((class sod-class))
256 (handler-case (c3-cpl class)
257 (inconsistent-merge-error ()
258 (error "Failed to compute class precedence list for `~A'"
259 (sod-class-name class)))))
261 ;;;--------------------------------------------------------------------------
264 (defmethod compute-chains ((class sod-class))
265 (with-default-error-location (class)
266 (with-slots (chain-link class-precedence-list) class
267 (let* ((head (if chain-link
268 (sod-class-chain-head chain-link)
270 (chain (cons class (and chain-link
271 (sod-class-chain chain-link))))
272 (state (make-inheritance-path-reporter-state class))
273 (table (make-hash-table)))
275 ;; Check the chains. We work through each superclass, maintaining a
276 ;; hash table keyed by class. If we encounter a class C which links
277 ;; to L, then we store C as L's value; if L already has a value then
278 ;; we've found an error. By the end of all of this, the classes
279 ;; which don't have an entry are the chain tails.
280 (dolist (super class-precedence-list)
281 (let* ((link (sod-class-chain-link super))
282 (found (and link (gethash link table))))
283 (cond ((not found) (setf (gethash link table) super))
285 (cerror* "Conflicting chains in class `~A': ~
286 (`~A' and `~A' both link to `~A')"
287 class super found link)
288 (report-inheritance-path state super)
289 (report-inheritance-path state found)))))
294 (mapcar #'sod-class-chain
295 (remove-if (lambda (super)
296 (gethash super table))
297 (cdr class-precedence-list)))))))))
299 ;;;--------------------------------------------------------------------------
302 (defmethod guess-metaclass ((class sod-class))
303 "Default metaclass-guessing function for classes.
305 Return the most specific metaclass of any of the CLASS's direct
308 ;; During bootstrapping, our superclasses might not have their own
309 ;; metaclasses resolved yet. If we find this, then throw `bootstrapping'
310 ;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
311 ;; across the bows of anyone else who calls us).
312 (finalization-error (:bad-metaclass)
313 (select-minimal-class-property (sod-class-direct-superclasses class)
315 (if (slot-boundp super 'metaclass)
316 (slot-value super 'metaclass)
317 (throw 'bootstrapping nil)))
318 #'sod-subclass-p class "metaclass")))
320 ;;;--------------------------------------------------------------------------
323 (defmethod check-sod-class ((class sod-class))
324 (with-default-error-location (class)
326 ;; Check the names of things are valid.
327 (flet ((check-list (list what namefunc)
329 (let ((name (funcall namefunc item)))
330 (unless (valid-name-p name)
331 (cerror*-with-location item
332 "Invalid ~A name `~A' ~
334 what name class))))))
335 (unless (valid-name-p (sod-class-name class))
336 (cerror* "Invalid class name `~A'" class))
337 (unless (valid-name-p (sod-class-nickname class))
338 (cerror* "Invalid class nickname `~A' for class `~A'"
339 (sod-class-nickname class) class))
340 (check-list (sod-class-messages class) "message" #'sod-message-name)
341 (check-list (sod-class-slots class) "slot" #'sod-slot-name))
343 ;; Check that the class doesn't define conflicting things.
344 (labels ((check-list (list keyfunc complain)
345 (let ((seen (make-hash-table :test #'equal)))
347 (let* ((key (funcall keyfunc item))
348 (found (gethash key seen)))
349 (if found (funcall complain item found)
350 (setf (gethash key seen) item))))))
351 (simple-previous (previous)
352 (info-with-location previous "Previous definition was here"))
353 (simple-complain (what namefunc)
354 (lambda (item previous)
355 (cerror*-with-location item
356 "Duplicate ~A `~A' in class `~A'"
357 what (funcall namefunc item) class)
358 (simple-previous previous))))
360 ;; Make sure direct slots have distinct names.
361 (check-list (sod-class-slots class) #'sod-slot-name
362 (simple-complain "slot name" #'sod-slot-name))
364 ;; Make sure there's at most one initializer for each slot.
365 (flet ((check-initializer-list (list kind)
366 (check-list list #'sod-initializer-slot
367 (lambda (initializer previous)
369 (sod-initializer-slot initializer)))
370 (cerror*-with-location initializer
376 (simple-previous previous))))))
377 (check-initializer-list (sod-class-instance-initializers class)
379 (check-initializer-list (sod-class-class-initializers class)
382 ;; Make sure messages have distinct names.
383 (check-list (sod-class-messages class) #'sod-message-name
384 (simple-complain "message name" #'sod-message-name))
386 ;; Make sure methods are sufficiently distinct.
387 (check-list (sod-class-methods class) #'sod-method-function-name
388 (lambda (method previous)
389 (cerror*-with-location method
390 "Duplicate ~A direct method ~
393 (sod-method-description method)
394 (sod-method-message method)
396 (simple-previous previous)))
398 ;; Make sure superclasses have distinct nicknames.
399 (let ((state (make-inheritance-path-reporter-state class)))
400 (check-list (sod-class-precedence-list class) #'sod-class-nickname
401 (lambda (super previous)
402 (cerror*-with-location class
403 "Duplicate nickname `~A' ~
404 in superclasses of `~A': ~
405 used by `~A' and `~A'"
406 (sod-class-nickname super)
407 class super previous)
408 (report-inheritance-path state super)
409 (report-inheritance-path state previous)))))
411 ;; Check that the CHAIN-TO class is actually a proper superclass. (This
412 ;; eliminates hairy things like a class being its own link.)
413 (let ((link (sod-class-chain-link class)))
414 (unless (or (not link)
415 (member link (cdr (sod-class-precedence-list class))))
416 (cerror* "In `~A~, chain-to class `~A' is not a proper superclass"
419 ;; Check that the initargs declare compatible types. Duplicate entries,
420 ;; even within a class, are harmless, but at most one initarg in any
421 ;; class should declare a default value.
422 (let ((seen (make-hash-table :test #'equal))
423 (state (make-inheritance-path-reporter-state class)))
424 (dolist (super (sod-class-precedence-list class))
425 (dolist (initarg (reverse (sod-class-initargs super)))
426 (let* ((initarg-name (sod-initarg-name initarg))
427 (initarg-type (sod-initarg-type initarg))
428 (initarg-default (sod-initarg-default initarg))
429 (found (gethash initarg-name seen))
430 (found-type (and found (sod-initarg-type found)))
431 (found-default (and found (sod-initarg-default found)))
432 (found-class (and found (sod-initarg-class found)))
433 (found-location (and found (file-location found))))
434 (with-default-error-location (initarg)
436 (setf (gethash initarg-name seen) initarg))
437 ((not (c-type-equal-p initarg-type found-type))
438 (cerror* "Inititalization argument `~A' defined ~
439 with incompatible types: ~
440 ~A in class `~A', but ~A in class `~A'"
441 initarg-name initarg-type super
442 found-type found-class found-location)
443 (report-inheritance-path state super))
444 ((and initarg-default found-default
445 (eql super found-class))
446 (cerror* "Initialization argument `~A' redefined ~
449 (info-with-location found-location
450 "Previous definition is here"))
452 (setf (gethash initarg-name seen) initarg))))))))
454 ;; Check for circularity in the superclass graph. Since the superclasses
455 ;; should already be acyclic, it suffices to check that our class is not
456 ;; a superclass of any of its own direct superclasses.
457 (let ((circle (find-if (lambda (super)
458 (sod-subclass-p super class))
459 (sod-class-direct-superclasses class))))
461 (cerror* "`~A' is already a superclass of `~A'" class circle)
462 (report-inheritance-path (make-inheritance-path-reporter-state class)
465 ;; Check that the class has a unique root superclass.
466 (find-root-superclass class)
468 ;; Check that the metaclass is a subclass of each direct superclass's
470 (finalization-error (:bad-metaclass)
471 (let ((meta (sod-class-metaclass class)))
472 (dolist (super (sod-class-direct-superclasses class))
473 (let ((supermeta (sod-class-metaclass super)))
474 (unless (sod-subclass-p meta supermeta)
475 (cerror* "Metaclass `~A' of `~A' isn't a subclass of `~A'"
476 meta class supermeta)
477 (info-with-location super
478 "Direct superclass `~A' defined here ~
480 super supermeta))))))))
482 ;;;--------------------------------------------------------------------------
485 (defmethod finalize-sod-class :around ((class sod-class))
486 "Common functionality for `finalize-sod-class'.
488 * If an attempt to finalize the CLASS has been made before, then we
489 don't try again. Similarly, attempts to finalize a class recursively
492 * A condition handler is established to keep track of whether any errors
493 are signalled during finalization. The CLASS is only marked as
494 successfully finalized if no (unhandled) errors are encountered."
495 (with-default-error-location (class)
496 (ecase (sod-class-state class)
499 ;; If this fails, leave the class marked as a loss.
500 (setf (slot-value class 'state) :broken)
502 ;; Invoke the finalization method proper. If it signals any
503 ;; continuable errors, take note of them so that we can report failure
506 ;; Catch: we get called recursively to clean up superclasses and
507 ;; metaclasses, but there should only be one such handler, so don't
508 ;; add another. (In turn, this means that other methods mustn't
509 ;; actually trap their significant errors.)
510 (let ((have-handler-p (boundp '*finalization-errors*))
511 (*finalization-errors* nil)
512 (*finalization-error-token* nil))
513 (catch '%finalization-failed
514 (if have-handler-p (call-next-method)
515 (handler-bind ((error (lambda (cond)
516 (declare (ignore cond))
517 (pushnew *finalization-error-token*
518 *finalization-errors*
522 (when *finalization-errors* (finalization-failed))
523 (setf (slot-value class 'state) :finalized)
526 ;; If the class is broken, we're not going to be able to fix it now.
530 ;; If we already finalized it, there's no point doing it again.
534 (defmethod finalize-sod-class ((class sod-class))
536 ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
537 ;; clone of the CPL and chain establishment code. If the interface changes
538 ;; then `bootstrap-classes' will need to be changed too.
540 ;; Set up the metaclass if it's not been set already. This is delayed
541 ;; to give bootstrapping a chance to set up metaclass and superclass
543 (default-slot (class 'metaclass) (guess-metaclass class))
545 ;; Finalize all of the superclasses. There's some special pleading here to
546 ;; make bootstrapping work: we don't try to finalize the metaclass if we're
547 ;; a root class (no direct superclasses -- because in that case the
548 ;; metaclass will have to be a subclass of us!), or if it's equal to us.
549 ;; This is enough to tie the knot at the top of the class graph. If we
550 ;; can't manage this then we're doomed.
551 (flet ((try-finalizing (what other-class)
552 (unless (finalize-sod-class other-class)
553 (cerror* "Class `~A' has broken ~A `~A'" class what other-class)
554 (info-with-location other-class
555 "Class `~A' defined here" other-class)
556 (finalization-failed))))
557 (let ((supers (sod-class-direct-superclasses class))
558 (meta (sod-class-metaclass class)))
559 (dolist (super supers)
560 (try-finalizing "direct superclass" super))
561 (unless (or (null supers) (eq class meta))
562 (try-finalizing "metaclass" meta))))
564 ;; Stash the class's type.
565 (setf (slot-value class '%type)
566 (make-class-type (sod-class-name class)))
568 ;; Clobber the lists of items if they've not been set.
569 (dolist (slot '(slots instance-initializers class-initializers
571 (unless (slot-boundp class slot)
572 (setf (slot-value class slot) nil)))
574 ;; If the CPL hasn't been done yet, compute it. If we can't manage this
575 ;; then there's no hope at all.
576 (unless (slot-boundp class 'class-precedence-list)
578 (setf (slot-value class 'class-precedence-list) (compute-cpl class))
579 (continue () :report "Continue"
580 (finalization-failed))))
582 ;; Check that the class is fairly sane.
583 (check-sod-class class)
585 ;; Determine the class's layout.
586 (setf (values (slot-value class 'chain-head)
587 (slot-value class 'chain)
588 (slot-value class 'chains))
589 (compute-chains class)))
591 ;;;----- That's all, folks --------------------------------------------------