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
51 ;;; Tiebreaker functions.
53 (defun clos-tiebreaker (candidates so-far)
54 "The CLOS linearization tiebreaker function.
56 Intended for use with `merge-lists'. Returns the member of CANDIDATES
57 which has a direct subclass furthest to the right in the list SO-FAR.
59 This must disambiguate. The SO-FAR list cannot be empty, since the class
60 under construction precedes all of the others. If two classes share a
61 direct subclass then that subclass's direct superclasses list must order
62 them relative to each other."
65 (dolist (class so-far)
66 (dolist (candidate candidates)
67 (when (member candidate (sod-class-direct-superclasses class))
68 (setf winner candidate))))
70 (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
73 (defun c3-tiebreaker (candidates cpls)
74 "The C3 linearization tiebreaker function.
76 Intended for use with `merge-lists'. Returns the member of CANDIDATES
77 which appears in the earliest element of CPLS, which should be the list of
78 the class precedence lists of the direct superclasses of the class in
79 question, in the order specified in the class declaration.
81 The only class in the class precedence list which does not appear in one
82 of these lists is the new class itself, which must precede all of the
85 This must disambiguate, since if two classes are in the same class
86 precedence list, then one must appear in it before the other, which
87 provides an ordering between them. (In this situation we return the one
88 that matches earliest anyway, which would still give the right answer.)
90 Note that this will merge the CPLs of superclasses /as they are/, not
91 necessarily as C3 would have computed them. This ensures monotonicity
92 assuming that the superclass CPLs are already monotonic. If they aren't,
93 you're going to lose anyway."
96 (dolist (candidate candidates)
97 (when (member candidate cpl)
98 (return-from c3-tiebreaker candidate))))
99 (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
101 ;;; Linearization functions.
104 (defun clos-cpl (class)
105 "Compute the class precedence list of CLASS using CLOS linearization rules.
107 We merge the direct-superclass lists of all of CLASS's superclasses,
108 disambiguating using `clos-tiebreaker'.
110 The CLOS linearization preserves local class ordering, but is not
111 monotonic, and does not respect the extended precedence graph. CLOS
112 linearization will succeed whenever Dylan or C3 linearization succeeds;
113 the converse is not true."
115 (labels ((superclasses (class)
116 (let ((direct-supers (sod-class-direct-superclasses class)))
117 (remove-duplicates (cons class
118 (mappend #'superclasses
120 (merge-lists (mapcar (lambda (class)
122 (sod-class-direct-superclasses class)))
123 (superclasses class))
124 :pick #'clos-tiebreaker)))
127 (defun dylan-cpl (class)
128 "Compute the class precedence list of CLASS using Dylan linearization
131 We merge the direct-superclass list of CLASS with the full class
132 precedence lists of its direct superclasses, disambiguating using
133 `clos-tiebreaker'. (Inductively, these lists will be consistent with the
134 CPLs of indirect superclasses, since those CPLs' orderings are reflected
135 in the CPLs of the direct superclasses.)
137 The Dylan linearization preserves local class ordering and is monotonic,
138 but does not respect the extended precedence graph.
140 Note that this will merge the CPLs of superclasses /as they are/, not
141 necessarily as Dylan would have computed them. This ensures monotonicity
142 assuming that the superclass CPLs are already monotonic. If they aren't,
143 you're going to lose anyway."
145 (let ((direct-supers (sod-class-direct-superclasses class)))
146 (merge-lists (cons (cons class direct-supers)
147 (mapcar #'sod-class-precedence-list direct-supers))
148 :pick #'clos-tiebreaker)))
151 (defun c3-cpl (class)
152 "Compute the class precedence list of CLASS using C3 linearization rules.
154 We merge the direct-superclass list of CLASS with the full class
155 precedence lists of its direct superclasses, disambiguating using
158 The C3 linearization preserves local class ordering, is monotonic, and
159 respects the extended precedence graph. It is the linearization used in
160 Python, Perl 6 and other languages. It is the recommended linearization
163 (let* ((direct-supers (sod-class-direct-superclasses class))
164 (cpls (mapcar #'sod-class-precedence-list direct-supers)))
165 (merge-lists (cons (cons class direct-supers) cpls)
166 :pick (lambda (candidates so-far)
167 (declare (ignore so-far))
168 (c3-tiebreaker candidates cpls)))))
170 (export 'flavors-cpl)
171 (defun flavors-cpl (class)
172 "Compute the class precedence list of CLASS using Flavors linearization
175 We do a depth-first traversal of the superclass graph, ignoring duplicates
176 of classes we've already visited. Interestingly, this has the property of
177 being able to tolerate cyclic superclass graphs, though defining cyclic
178 graphs is syntactically impossible in SOD.
180 This linearization has few other redeeming features, however. In
181 particular, the top class tends not to be at the end of the CPL, despite
182 it being unequivocally less specific than any other class."
185 (labels ((walk (class)
186 (unless (member class done)
188 (dolist (super (sod-class-direct-superclasses class))
194 (defun python-cpl (class)
195 "Compute the class precedence list of CLASS using the documented Python 2.2
198 We do a depth-first traversal of the superclass graph, retaining only the
199 last occurrence of each class visited.
201 This linearization has few redeeming features. It was never actually
202 implemented; the true Python 2.2 linearization seems closer to (but
203 different from) L*LOOPS."
206 (labels ((walk (class)
208 (dolist (super (sod-class-direct-superclasses class))
211 (delete-duplicates (nreverse done)))))
213 (export 'l*loops-cpl)
214 (defun l*loops-cpl (class)
215 "Compute the class precedence list of CLASS using L*LOOPS linearization
218 We merge the class precedence lists of the direct superclasses of CLASS,
219 disambiguating by choosing the earliest candidate which appears in a
220 depth-first walk of the superclass graph.
222 The L*LOOPS rules are monotonic and respect the extended precedence
223 graph. However (unlike Dylan and CLOS) they don't respect local
224 precedence order i.e., the direct-superclasses list orderings."
226 (let ((dfs (flavors-cpl class)))
227 (cons class (merge-lists (mapcar #'sod-class-precedence-list
228 (sod-class-direct-superclasses class))
229 :pick (lambda (candidates so-far)
230 (declare (ignore so-far))
232 (when (member class candidates)
233 (return class))))))))
235 ;;; Default function.
237 (defmethod compute-cpl ((class sod-class))
238 (handler-case (c3-cpl class)
239 (inconsistent-merge-error ()
240 (error "Failed to compute class precedence list for `~A'"
241 (sod-class-name class)))))
243 ;;;--------------------------------------------------------------------------
246 (defmethod compute-chains ((class sod-class))
247 (with-default-error-location (class)
248 (with-slots (chain-link class-precedence-list) class
249 (let* ((head (if chain-link
250 (sod-class-chain-head chain-link)
252 (chain (cons class (and chain-link
253 (sod-class-chain chain-link))))
254 (table (make-hash-table)))
256 ;; Check the chains. We work through each superclass, maintaining a
257 ;; hash table keyed by class. If we encounter a class C which links
258 ;; to L, then we store C as L's value; if L already has a value then
259 ;; we've found an error. By the end of all of this, the classes
260 ;; which don't have an entry are the chain tails.
261 (dolist (super class-precedence-list)
262 (let ((link (sod-class-chain-link super)))
264 (when (gethash link table)
265 (error "Conflicting chains in class ~A: ~
266 (~A and ~A both link to ~A)"
267 class super (gethash link table) link))
268 (setf (gethash link table) super))))
273 (mapcar #'sod-class-chain
274 (remove-if (lambda (super)
275 (gethash super table))
276 (cdr class-precedence-list)))))))))
278 ;;;--------------------------------------------------------------------------
281 (defmethod check-sod-class ((class sod-class))
282 (with-default-error-location (class)
284 ;; Check the names of things are valid.
285 (with-slots (name nickname messages) class
286 (unless (valid-name-p name)
287 (error "Invalid class name `~A'" class))
288 (unless (valid-name-p nickname)
289 (error "Invalid class nickname `~A' on class `~A'" nickname class))
290 (dolist (message messages)
291 (unless (valid-name-p (sod-message-name message))
292 (error "Invalid message name `~A' on class `~A'"
293 (sod-message-name message) class))))
295 ;; Check that the slots and messages have distinct names.
296 (with-slots (slots messages class-precedence-list) class
297 (flet ((check-list (list what namefunc)
298 (let ((table (make-hash-table :test #'equal)))
300 (let ((name (funcall namefunc item)))
301 (if (gethash name table)
302 (error "Duplicate ~A name `~A' on class `~A'"
304 (setf (gethash name table) item)))))))
305 (check-list slots "slot" #'sod-slot-name)
306 (check-list messages "message" #'sod-message-name)
307 (check-list class-precedence-list "nickname" #'sod-class-name)))
309 ;; Check that the CHAIN-TO class is actually a proper superclass. (This
310 ;; eliminates hairy things like a class being its own link.)
311 (with-slots (class-precedence-list chain-link) class
312 (unless (or (not chain-link)
313 (member chain-link (cdr class-precedence-list)))
314 (error "In `~A~, chain-to class `~A' is not a proper superclass"
317 ;; Check for circularity in the superclass graph. Since the superclasses
318 ;; should already be acyclic, it suffices to check that our class is not
319 ;; a superclass of any of its own direct superclasses.
320 (let ((circle (find-if (lambda (super)
321 (sod-subclass-p super class))
322 (sod-class-direct-superclasses class))))
324 (error "Circularity: ~A is already a superclass of ~A"
327 ;; Check that the class has a unique root superclass.
328 (find-root-superclass class)
330 ;; Check that the metaclass is a subclass of each direct superclass's
332 (with-slots (metaclass direct-superclasses) class
333 (dolist (super direct-superclasses)
334 (unless (sod-subclass-p metaclass (sod-class-metaclass super))
335 (error "Incompatible metaclass for `~A': ~
336 `~A' isn't a subclass of `~A' (of `~A')"
337 class metaclass (sod-class-metaclass super) super))))))
339 ;;;--------------------------------------------------------------------------
342 (defmethod finalize-sod-class ((class sod-class))
344 ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
345 ;; clone of the CPL and chain establishment code. If the interface changes
346 ;; then `bootstrap-classes' will need to be changed too.
348 (with-default-error-location (class)
349 (ecase (sod-class-state class)
352 ;; If this fails, mark the class as a loss.
353 (setf (slot-value class 'state) :broken)
355 ;; Finalize all of the superclasses. There's some special pleading
356 ;; here to make bootstrapping work: we don't try to finalize the
357 ;; metaclass if we're a root class (no direct superclasses -- because
358 ;; in that case the metaclass will have to be a subclass of us!), or
359 ;; if it's equal to us. This is enough to tie the knot at the top of
361 (with-slots (name direct-superclasses metaclass) class
362 (dolist (super direct-superclasses)
363 (finalize-sod-class super))
364 (unless (or (null direct-superclasses)
365 (eq class metaclass))
366 (finalize-sod-class metaclass)))
368 ;; Stash the class's type.
369 (setf (slot-value class '%type)
370 (make-class-type (sod-class-name class)))
372 ;; Clobber the lists of items if they've not been set.
373 (dolist (slot '(slots instance-initializers class-initializers
375 (unless (slot-boundp class slot)
376 (setf (slot-value class slot) nil)))
378 ;; If the CPL hasn't been done yet, compute it.
379 (with-slots (class-precedence-list) class
380 (unless (slot-boundp class 'class-precedence-list)
381 (setf class-precedence-list (compute-cpl class))))
383 ;; Check that the class is fairly sane.
384 (check-sod-class class)
386 ;; Determine the class's layout.
387 (with-slots (chain-head chain chains) class
388 (setf (values chain-head chain chains) (compute-chains class)))
391 (setf (slot-value class 'state) :finalized)
400 (macrolet ((define-layout-slot (slot (class) &body body)
401 `(define-on-demand-slot sod-class ,slot (,class)
402 (check-class-is-finalized ,class)
404 (flet ((check-class-is-finalized (class)
405 (unless (eq (sod-class-state class) :finalized)
406 (error "Class ~S is not finalized" class))))
407 (define-layout-slot %ilayout (class)
408 (compute-ilayout class))
409 (define-layout-slot effective-methods (class)
410 (compute-effective-methods class))
411 (define-layout-slot vtables (class)
412 (compute-vtables class))))
414 ;;;----- That's all, folks --------------------------------------------------