3 ;;; Computing class precedence lists
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Simple Object Definition system.
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 ;;;--------------------------------------------------------------------------
31 ;; Just for fun, we implement a wide selection. C3 seems to be clearly the
32 ;; 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 (defun clos-tiebreaker (candidates so-far)
52 "The CLOS linearization tiebreaker function.
54 Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
55 has a direct subclass furthest to the right in the list SO-FAR.
57 This must disambiguate. The SO-FAR list cannot be empty, since the class
58 under construction precedes all of the others. If two classes share a
59 direct subclass then that subclass's direct superclasses list must order
60 them relative to each other."
63 (dolist (class so-far)
64 (dolist (candidate candidates)
65 (when (member candidate (sod-class-direct-superclasses class))
66 (setf winner candidate))))
68 (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
71 (defun clos-cpl (class)
72 "Compute the class precedence list of CLASS using CLOS linearization rules.
74 We merge the direct-superclass lists of all of CLASS's superclasses,
75 disambiguating using CLOS-TIEBREAKER.
77 The CLOS linearization preserves local class ordering, but is not
78 monotonic, and does not respect the extended precedence graph. CLOS
79 linearization will succeed whenever Dylan or C3 linearization succeeds;
80 the converse is not true."
82 (labels ((superclasses (class)
83 (let ((direct-supers (sod-class-direct-superclasses class)))
84 (remove-duplicates (cons class
86 (mapcar #'superclasses
89 :initial-value nil))))))
90 (merge-lists (mapcar (lambda (class)
92 (sod-class-direct-superclasses class)))
94 :pick #'clos-tiebreaker)))
96 (defun dylan-cpl (class)
97 "Compute the class precedence list of CLASS using Dylan linearization
100 We merge the direct-superclass list of CLASS with the full class
101 precedence lists of its direct superclasses, disambiguating using
102 CLOS-TIEBREAKER. (Inductively, these lists will be consistent with the
103 CPLs of indirect superclasses, since those CPLs' orderings are reflected
104 in the CPLs of the direct superclasses.)
106 The Dylan linearization preserves local class ordering and is monotonic,
107 but does not respect the extended precedence graph.
109 Note that this will merge the CPLs of superclasses /as they are/, not
110 necessarily as Dylan would have computed them. This ensures monotonicity
111 assuming that the superclass CPLs are already monotonic. If they aren't,
112 you're going to lose anyway."
114 (let ((direct-supers (sod-class-direct-superclasses class)))
115 (merge-lists (cons (cons class direct-supers)
116 (mapcar #'sod-class-precedence-list direct-supers))
117 :pick #'clos-tiebreaker)))
119 (defun c3-tiebreaker (candidates cpls)
120 "The C3 linearization tiebreaker function.
122 Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
123 appears in the earliest element of CPLS, which should be the list of the
124 class precedence lists of the direct superclasses of the class in
125 question, in the order specified in the class declaration.
127 The only class in the class precedence list which does not appear in one
128 of these lists is the new class itself, which must precede all of the
131 This must disambiguate, since if two classes are in the same class
132 precedence list, then one must appear in it before the other, which
133 provides an ordering between them. (In this situation we return the one
134 that matches earliest anyway, which would still give the right answer.)
136 Note that this will merge the CPLs of superclasses /as they are/, not
137 necessarily as C3 would have computed them. This ensures monotonicity
138 assuming that the superclass CPLs are already monotonic. If they aren't,
139 you're going to lose anyway."
142 (dolist (candidate candidates)
143 (when (member candidate cpl)
144 (return-from c3-tiebreaker candidate))))
145 (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
147 (defun c3-cpl (class)
148 "Compute the class precedence list of CLASS using C3 linearization rules.
150 We merge the direct-superclass list of CLASS with the full class
151 precedence lists of its direct superclasses, disambiguating using
154 The C3 linearization preserves local class ordering, is monotonic, and
155 respects the extended precedence graph. It is the linearization used in
156 Python, Perl 6 and other languages. It is the recommended linearization
159 (let* ((direct-supers (sod-class-direct-superclasses class))
160 (cpls (mapcar #'sod-class-precedence-list direct-supers)))
161 (merge-lists (cons (cons class direct-supers) cpls)
162 :pick (lambda (candidates so-far)
163 (declare (ignore so-far))
164 (c3-tiebreaker candidates cpls)))))
166 (defun flavors-cpl (class)
167 "Compute the class precedence list of CLASS using Flavors linearization
170 We do a depth-first traversal of the superclass graph, ignoring duplicates
171 of classes we've already visited. Interestingly, this has the property of
172 being able to tolerate cyclic superclass graphs, though defining cyclic
173 graphs is syntactically impossible in SOD.
175 This linearization has few other redeeming features, however. In
176 particular, the top class tends not to be at the end of the CPL, despite
177 it being unequivocally less specific than any other class."
180 (labels ((walk (class)
181 (unless (member class done)
183 (dolist (super (sod-class-direct-superclasses class))
188 (defun python-cpl (class)
189 "Compute the class precedence list of CLASS using the documented Python 2.2
192 We do a depth-first traversal of the superclass graph, retaining only the
193 last occurrence of each class visited.
195 This linearization has few redeeming features. It was never actually
196 implemented; the true Python 2.2 linearization seems closer to (but
197 different from) L*LOOPS."
200 (labels ((walk (class)
202 (dolist (super (sod-class-direct-superclasses class))
205 (delete-duplicates (nreverse done)))))
207 (defun l*loops-cpl (class)
208 "Compute the class precedence list of CLASS using L*LOOPS linearization
211 We merge the class precedence lists of the direct superclasses of CLASS,
212 disambiguating by choosing the earliest candidate which appears in a
213 depth-first walk of the superclass graph.
215 The L*LOOPS rules are monotonic and respect the extended precedence
216 graph. However (unlike Dylan and CLOS) they don't respect local
217 precedence order i.e., the direct-superclasses list orderings."
219 (let ((dfs (flavors-cpl class)))
220 (cons class (merge-lists (mapcar #'sod-class-precedence-list
221 (sod-class-direct-superclasses class))
222 :pick (lambda (candidates so-far)
223 (declare (ignore so-far))
225 (when (member class candidates)
226 (return class))))))))
228 ;;;--------------------------------------------------------------------------
231 (defgeneric compute-cpl (class)
233 "Returns the class precedence list for CLASS."))
235 (defmethod compute-cpl ((class sod-class))
236 (handler-case (c3-cpl class)
237 (inconsistent-merge-error ()
238 (error "Failed to compute class precedence list for `~A'"
239 (sod-class-name class)))))
241 ;;;--------------------------------------------------------------------------
246 (defclass test-class ()
247 ((name :initarg :name :accessor sod-class-name)
248 (direct-superclasses :initarg :superclasses
249 :accessor sod-class-direct-superclasses)
250 (class-precedence-list)))
252 (defmethod print-object ((class test-class) stream)
254 (print-unreadable-object (class stream :type t :identity nil)
255 (princ (sod-class-name class) stream))
256 (princ (sod-class-name class) stream)))
258 (defvar *test-linearization*)
260 (defmethod sod-class-precedence-list ((class test-class))
261 (if (slot-boundp class 'class-precedence-list)
262 (slot-value class 'class-precedence-list)
263 (setf (slot-value class 'class-precedence-list)
264 (funcall *test-linearization* class)))))
267 (defun test-cpl (linearization heterarchy)
268 (let* ((*test-linearization* linearization)
269 (classes (make-hash-table :test #'equal)))
270 (dolist (class heterarchy)
271 (let ((name (car class)))
272 (setf (gethash (car class) classes)
273 (make-instance 'test-class :name name))))
274 (dolist (class heterarchy)
275 (setf (sod-class-direct-superclasses (gethash (car class) classes))
276 (mapcar (lambda (super) (gethash super classes)) (cdr class))))
277 (mapcar (lambda (class)
279 (mapcar #'sod-class-name
280 (sod-class-precedence-list (gethash (car class)
282 (inconsistent-merge-error ()
283 (list (car class) :error))))
288 (defparameter *confused-heterarchy*
289 '((object) (grid-layout object)
290 (horizontal-grid grid-layout) (vertical-grid grid-layout)
291 (hv-grid horizontal-grid vertical-grid)
292 (vh-grid vertical-grid horizontal-grid)
293 (confused-grid hv-grid vh-grid)))
294 (defparameter *boat-heterarchy*
299 (engine-less day-boat)
300 (small-multihull day-boat)
301 (pedal-wheel-boat engine-less wheel-boat)
302 (small-catamaran small-multihull)
303 (pedalo pedal-wheel-boat small-catamaran)))
304 (defparameter *menu-heterarchy*
306 (choice-widget object)
309 (popup-menu menu popup-mixin)
310 (new-popup-menu menu popup-mixin choice-widget)))
311 (defparameter *pane-heterarchy*
312 '((pane) (scrolling-mixin) (editing-mixin)
313 (scrollable-pane pane scrolling-mixin)
314 (editable-pane pane editing-mixin)
315 (editable-scrollable-pane scrollable-pane editable-pane)))
316 (defparameter *baker-nonmonotonic-heterarchy*
317 '((z) (x z) (y) (b y) (a b x) (c a b x y)))
318 (defparameter *baker-nonassociative-heterarchy*
319 '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
320 (defparameter *distinguishing-heterarchy*
322 (a object) (b object) (c object)
328 (defparameter *python-heterarchy*
330 (a object) (b object) (c object) (d object) (e object)
336 ;;;----- That's all, folks --------------------------------------------------