chiark - git - mdw - sod/blob - cpl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Computing class precedence lists
   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 ;;; Linearizations.
  30
  31 ;; Just for fun, we implement a wide selection.  C3 seems to be clearly the
  32 ;; best, with fewer sharp edges for the unwary.
  33 ;;
  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.
  41 ;;
  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
  45 ;; linearized.
  46 ;;
  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
  50
  51 (defun clos-tiebreaker (candidates so-far)
  52   "The CLOS linearization tiebreaker function.
  53
  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.
  56
  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."
  61
  62   (let (winner)
  63     (dolist (class so-far)
  64       (dolist (candidate candidates)
  65         (when (member candidate (sod-class-direct-superclasses class))
  66           (setf winner candidate))))
  67     (unless winner
  68       (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
  69     winner))
  70
  71 (defun clos-cpl (class)
  72   "Compute the class precedence list of CLASS using CLOS linearization rules.
  73
  74    We merge the direct-superclass lists of all of CLASS's superclasses,
  75    disambiguating using CLOS-TIEBREAKER.
  76
  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."
  81
  82   (labels ((superclasses (class)
  83              (let ((direct-supers (sod-class-direct-superclasses class)))
  84                (remove-duplicates (cons class
  85                                         (mappend #'superclasses
  86                                                  direct-supers))))))
  87     (merge-lists (mapcar (lambda (class)
  88                            (cons class
  89                                  (sod-class-direct-superclasses class)))
  90                          (superclasses class))
  91                  :pick #'clos-tiebreaker)))
  92
  93 (defun dylan-cpl (class)
  94   "Compute the class precedence list of CLASS using Dylan linearization
  95    rules.
  96
  97    We merge the direct-superclass list of CLASS with the full class
  98    precedence lists of its direct superclasses, disambiguating using
  99    CLOS-TIEBREAKER.  (Inductively, these lists will be consistent with the
 100    CPLs of indirect superclasses, since those CPLs' orderings are reflected
 101    in the CPLs of the direct superclasses.)
 102
 103    The Dylan linearization preserves local class ordering and is monotonic,
 104    but does not respect the extended precedence graph.
 105
 106    Note that this will merge the CPLs of superclasses /as they are/, not
 107    necessarily as Dylan 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."
 110
 111   (let ((direct-supers (sod-class-direct-superclasses class)))
 112     (merge-lists (cons (cons class direct-supers)
 113                        (mapcar #'sod-class-precedence-list direct-supers))
 114                  :pick #'clos-tiebreaker)))
 115
 116 (defun c3-tiebreaker (candidates cpls)
 117   "The C3 linearization tiebreaker function.
 118
 119    Intended for use with MERGE-LISTS.  Returns the member of CANDIDATES which
 120    appears in the earliest element of CPLS, which should be the list of the
 121    class precedence lists of the direct superclasses of the class in
 122    question, in the order specified in the class declaration.
 123
 124    The only class in the class precedence list which does not appear in one
 125    of these lists is the new class itself, which must precede all of the
 126    others.
 127
 128    This must disambiguate, since if two classes are in the same class
 129    precedence list, then one must appear in it before the other, which
 130    provides an ordering between them.  (In this situation we return the one
 131    that matches earliest anyway, which would still give the right answer.)
 132
 133    Note that this will merge the CPLs of superclasses /as they are/, not
 134    necessarily as C3 would have computed them.  This ensures monotonicity
 135    assuming that the superclass CPLs are already monotonic.  If they aren't,
 136    you're going to lose anyway."
 137
 138   (dolist (cpl cpls)
 139     (dolist (candidate candidates)
 140       (when (member candidate cpl)
 141         (return-from c3-tiebreaker candidate))))
 142   (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
 143
 144 (defun c3-cpl (class)
 145   "Compute the class precedence list of CLASS using C3 linearization rules.
 146
 147    We merge the direct-superclass list of CLASS with the full class
 148    precedence lists of its direct superclasses, disambiguating using
 149    C3-TIEBREAKER.
 150
 151    The C3 linearization preserves local class ordering, is monotonic, and
 152    respects the extended precedence graph.  It is the linearization used in
 153    Python, Perl 6 and other languages.  It is the recommended linearization
 154    for SOD."
 155
 156   (let* ((direct-supers (sod-class-direct-superclasses class))
 157          (cpls (mapcar #'sod-class-precedence-list direct-supers)))
 158     (merge-lists (cons (cons class direct-supers) cpls)
 159                  :pick (lambda (candidates so-far)
 160                          (declare (ignore so-far))
 161                          (c3-tiebreaker candidates cpls)))))
 162
 163 (defun flavors-cpl (class)
 164   "Compute the class precedence list of CLASS using Flavors linearization
 165    rules.
 166
 167    We do a depth-first traversal of the superclass graph, ignoring duplicates
 168    of classes we've already visited.  Interestingly, this has the property of
 169    being able to tolerate cyclic superclass graphs, though defining cyclic
 170    graphs is syntactically impossible in SOD.
 171
 172    This linearization has few other redeeming features, however.  In
 173    particular, the top class tends not to be at the end of the CPL, despite
 174    it being unequivocally less specific than any other class."
 175
 176   (let ((done nil))
 177     (labels ((walk (class)
 178                (unless (member class done)
 179                  (push class done)
 180                  (dolist (super (sod-class-direct-superclasses class))
 181                    (walk super)))))
 182       (walk class)
 183       (nreverse done))))
 184
 185 (defun python-cpl (class)
 186   "Compute the class precedence list of CLASS using the documented Python 2.2
 187    linearization rules.
 188
 189    We do a depth-first traversal of the superclass graph, retaining only the
 190    last occurrence of each class visited.
 191
 192    This linearization has few redeeming features.  It was never actually
 193    implemented; the true Python 2.2 linearization seems closer to (but
 194    different from) L*LOOPS."
 195
 196   (let ((done nil))
 197     (labels ((walk (class)
 198                (push class done)
 199                (dolist (super (sod-class-direct-superclasses class))
 200                  (walk super))))
 201       (walk class)
 202       (delete-duplicates (nreverse done)))))
 203
 204 (defun l*loops-cpl (class)
 205   "Compute the class precedence list of CLASS using L*LOOPS linearization
 206    rules.
 207
 208    We merge the class precedence lists of the direct superclasses of CLASS,
 209    disambiguating by choosing the earliest candidate which appears in a
 210    depth-first walk of the superclass graph.
 211
 212    The L*LOOPS rules are monotonic and respect the extended precedence
 213    graph.  However (unlike Dylan and CLOS) they don't respect local
 214    precedence order i.e., the direct-superclasses list orderings."
 215
 216   (let ((dfs (flavors-cpl class)))
 217     (cons class (merge-lists (mapcar #'sod-class-precedence-list
 218                                      (sod-class-direct-superclasses class))
 219                              :pick (lambda (candidates so-far)
 220                                      (declare (ignore so-far))
 221                                      (dolist (class dfs)
 222                                        (when (member class candidates)
 223                                          (return class))))))))
 224
 225 ;;;--------------------------------------------------------------------------
 226 ;;; Class protocol.
 227
 228 (defgeneric compute-cpl (class)
 229   (:documentation
 230    "Returns the class precedence list for CLASS."))
 231
 232 (defmethod compute-cpl ((class sod-class))
 233   (handler-case (c3-cpl class)
 234     (inconsistent-merge-error ()
 235       (error "Failed to compute class precedence list for `~A'"
 236              (sod-class-name class)))))
 237
 238 ;;;--------------------------------------------------------------------------
 239 ;;; Testing.
 240
 241 #+test
 242 (progn
 243   (defclass test-class ()
 244     ((name :initarg :name :accessor sod-class-name)
 245      (direct-superclasses :initarg :superclasses
 246                           :accessor sod-class-direct-superclasses)
 247      (class-precedence-list)))
 248
 249   (defmethod print-object ((class test-class) stream)
 250     (if *print-escape*
 251         (print-unreadable-object (class stream :type t :identity nil)
 252           (princ (sod-class-name class) stream))
 253         (princ (sod-class-name class) stream)))
 254
 255   (defvar *test-linearization*)
 256
 257   (defmethod sod-class-precedence-list ((class test-class))
 258     (if (slot-boundp class 'class-precedence-list)
 259         (slot-value class 'class-precedence-list)
 260         (setf (slot-value class 'class-precedence-list)
 261               (funcall *test-linearization* class)))))
 262
 263 #+test
 264 (defun test-cpl (linearization heterarchy)
 265   (let* ((*test-linearization* linearization)
 266          (classes (make-hash-table :test #'equal)))
 267     (dolist (class heterarchy)
 268       (let ((name (car class)))
 269         (setf (gethash (car class) classes)
 270               (make-instance 'test-class :name name))))
 271     (dolist (class heterarchy)
 272       (setf (sod-class-direct-superclasses (gethash (car class) classes))
 273             (mapcar (lambda (super) (gethash super classes)) (cdr class))))
 274     (mapcar (lambda (class)
 275               (handler-case
 276                   (mapcar #'sod-class-name
 277                           (sod-class-precedence-list (gethash (car class)
 278                                                               classes)))
 279                 (inconsistent-merge-error ()
 280                   (list (car class) :error))))
 281             heterarchy)))
 282
 283 #+test
 284 (progn
 285   (defparameter *confused-heterarchy*
 286     '((object) (grid-layout object)
 287       (horizontal-grid grid-layout) (vertical-grid grid-layout)
 288       (hv-grid horizontal-grid vertical-grid)
 289       (vh-grid vertical-grid horizontal-grid)
 290       (confused-grid hv-grid vh-grid)))
 291   (defparameter *boat-heterarchy*
 292     '((object)
 293       (boat object)
 294       (day-boat boat)
 295       (wheel-boat boat)
 296       (engine-less day-boat)
 297       (small-multihull day-boat)
 298       (pedal-wheel-boat engine-less wheel-boat)
 299       (small-catamaran small-multihull)
 300       (pedalo pedal-wheel-boat small-catamaran)))
 301   (defparameter *menu-heterarchy*
 302     '((object)
 303       (choice-widget object)
 304       (menu choice-widget)
 305       (popup-mixin object)
 306       (popup-menu menu popup-mixin)
 307       (new-popup-menu menu popup-mixin choice-widget)))
 308   (defparameter *pane-heterarchy*
 309     '((pane) (scrolling-mixin) (editing-mixin)
 310       (scrollable-pane pane scrolling-mixin)
 311       (editable-pane pane editing-mixin)
 312       (editable-scrollable-pane scrollable-pane editable-pane)))
 313   (defparameter *baker-nonmonotonic-heterarchy*
 314     '((z) (x z) (y) (b y) (a b x) (c a b x y)))
 315   (defparameter *baker-nonassociative-heterarchy*
 316     '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
 317   (defparameter *distinguishing-heterarchy*
 318     '((object)
 319       (a object) (b object) (c object)
 320       (p a b) (q a c)
 321       (u p) (v q)
 322       (x u v)
 323       (y x b c)
 324       (z x c b)))
 325   (defparameter *python-heterarchy*
 326     '((object)
 327       (a object) (b object) (c object) (d object) (e object)
 328       (k1 a b c)
 329       (k2 d b e)
 330       (k3 d a)
 331       (z k1 k2 k3))))
 332
 333 ;;;----- That's all, folks --------------------------------------------------