chiark - git - mdw - sod/blob - src/class-finalize-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Class finalization implementation
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensble Object Design, an object system for C.
  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 precedence lists.
  30
  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.
  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 ;;; Tiebreaker functions.
  52
  53 (defun clos-tiebreaker (candidates so-far)
  54   "The CLOS linearization tiebreaker function.
  55
  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.
  58
  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."
  63
  64   (let (winner)
  65     (dolist (class so-far)
  66       (dolist (candidate candidates)
  67         (when (member candidate (sod-class-direct-superclasses class))
  68           (setf winner candidate))))
  69     (unless winner
  70       (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
  71     winner))
  72
  73 (defun c3-tiebreaker (candidates cpls)
  74   "The C3 linearization tiebreaker function.
  75
  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.
  80
  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
  83    others.
  84
  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.)
  89
  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."
  94
  95   (dolist (cpl cpls)
  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."))
 100
 101 ;;; Linearization functions.
 102
 103 (defun clos-cpl (class)
 104   "Compute the class precedence list of CLASS using CLOS linearization rules.
 105
 106    We merge the direct-superclass lists of all of CLASS's superclasses,
 107    disambiguating using `clos-tiebreaker'.
 108
 109    The CLOS linearization preserves local class ordering, but is not
 110    monotonic, and does not respect the extended precedence graph.  CLOS
 111    linearization will succeed whenever Dylan or C3 linearization succeeds;
 112    the converse is not true."
 113
 114   (labels ((superclasses (class)
 115              (let ((direct-supers (sod-class-direct-superclasses class)))
 116                (remove-duplicates (cons class
 117                                         (mappend #'superclasses
 118                                                  direct-supers))))))
 119     (merge-lists (mapcar (lambda (class)
 120                            (cons class
 121                                  (sod-class-direct-superclasses class)))
 122                          (superclasses class))
 123                  :pick #'clos-tiebreaker)))
 124
 125 (defun dylan-cpl (class)
 126   "Compute the class precedence list of CLASS using Dylan linearization
 127    rules.
 128
 129    We merge the direct-superclass list of CLASS with the full class
 130    precedence lists of its direct superclasses, disambiguating using
 131    `clos-tiebreaker'.  (Inductively, these lists will be consistent with the
 132    CPLs of indirect superclasses, since those CPLs' orderings are reflected
 133    in the CPLs of the direct superclasses.)
 134
 135    The Dylan linearization preserves local class ordering and is monotonic,
 136    but does not respect the extended precedence graph.
 137
 138    Note that this will merge the CPLs of superclasses /as they are/, not
 139    necessarily as Dylan would have computed them.  This ensures monotonicity
 140    assuming that the superclass CPLs are already monotonic.  If they aren't,
 141    you're going to lose anyway."
 142
 143   (let ((direct-supers (sod-class-direct-superclasses class)))
 144     (merge-lists (cons (cons class direct-supers)
 145                        (mapcar #'sod-class-precedence-list direct-supers))
 146                  :pick #'clos-tiebreaker)))
 147
 148 (defun c3-cpl (class)
 149   "Compute the class precedence list of CLASS using C3 linearization rules.
 150
 151    We merge the direct-superclass list of CLASS with the full class
 152    precedence lists of its direct superclasses, disambiguating using
 153    `c3-tiebreaker'.
 154
 155    The C3 linearization preserves local class ordering, is monotonic, and
 156    respects the extended precedence graph.  It is the linearization used in
 157    Python, Perl 6 and other languages.  It is the recommended linearization
 158    for SOD."
 159
 160   (let* ((direct-supers (sod-class-direct-superclasses class))
 161          (cpls (mapcar #'sod-class-precedence-list direct-supers)))
 162     (merge-lists (cons (cons class direct-supers) cpls)
 163                  :pick (lambda (candidates so-far)
 164                          (declare (ignore so-far))
 165                          (c3-tiebreaker candidates cpls)))))
 166
 167 (defun flavors-cpl (class)
 168   "Compute the class precedence list of CLASS using Flavors linearization
 169    rules.
 170
 171    We do a depth-first traversal of the superclass graph, ignoring duplicates
 172    of classes we've already visited.  Interestingly, this has the property of
 173    being able to tolerate cyclic superclass graphs, though defining cyclic
 174    graphs is syntactically impossible in SOD.
 175
 176    This linearization has few other redeeming features, however.  In
 177    particular, the top class tends not to be at the end of the CPL, despite
 178    it being unequivocally less specific than any other class."
 179
 180   (let ((done nil))
 181     (labels ((walk (class)
 182                (unless (member class done)
 183                  (push class done)
 184                  (dolist (super (sod-class-direct-superclasses class))
 185                    (walk super)))))
 186       (walk class)
 187       (nreverse done))))
 188
 189 (defun python-cpl (class)
 190   "Compute the class precedence list of CLASS using the documented Python 2.2
 191    linearization rules.
 192
 193    We do a depth-first traversal of the superclass graph, retaining only the
 194    last occurrence of each class visited.
 195
 196    This linearization has few redeeming features.  It was never actually
 197    implemented; the true Python 2.2 linearization seems closer to (but
 198    different from) L*LOOPS."
 199
 200   (let ((done nil))
 201     (labels ((walk (class)
 202                (push class done)
 203                (dolist (super (sod-class-direct-superclasses class))
 204                  (walk super))))
 205       (walk class)
 206       (delete-duplicates (nreverse done)))))
 207
 208 (defun l*loops-cpl (class)
 209   "Compute the class precedence list of CLASS using L*LOOPS linearization
 210    rules.
 211
 212    We merge the class precedence lists of the direct superclasses of CLASS,
 213    disambiguating by choosing the earliest candidate which appears in a
 214    depth-first walk of the superclass graph.
 215
 216    The L*LOOPS rules are monotonic and respect the extended precedence
 217    graph.  However (unlike Dylan and CLOS) they don't respect local
 218    precedence order i.e., the direct-superclasses list orderings."
 219
 220   (let ((dfs (flavors-cpl class)))
 221     (cons class (merge-lists (mapcar #'sod-class-precedence-list
 222                                      (sod-class-direct-superclasses class))
 223                              :pick (lambda (candidates so-far)
 224                                      (declare (ignore so-far))
 225                                      (dolist (class dfs)
 226                                        (when (member class candidates)
 227                                          (return class))))))))
 228
 229 ;;; Default function.
 230
 231 (defmethod compute-cpl ((class sod-class))
 232   (handler-case (c3-cpl class)
 233     (inconsistent-merge-error ()
 234       (error "Failed to compute class precedence list for `~A'"
 235              (sod-class-name class)))))
 236
 237 ;;;--------------------------------------------------------------------------
 238 ;;; Chains.
 239
 240 (defmethod compute-chains ((class sod-class))
 241   (with-default-error-location (class)
 242     (with-slots (chain-link class-precedence-list) class
 243       (let* ((head (if chain-link
 244                        (sod-class-chain-head chain-link)
 245                        class))
 246              (chain (cons class (and chain-link
 247                                      (sod-class-chain chain-link))))
 248              (table (make-hash-table)))
 249
 250         ;; Check the chains.  We work through each superclass, maintaining a
 251         ;; hash table keyed by class.  If we encounter a class C which links
 252         ;; to L, then we store C as L's value; if L already has a value then
 253         ;; we've found an error.  By the end of all of this, the classes
 254         ;; which don't have an entry are the chain tails.
 255         (dolist (super class-precedence-list)
 256           (let ((link (sod-class-chain-link super)))
 257             (when link
 258               (when (gethash link table)
 259                 (error "Conflicting chains in class ~A: ~
 260                         (~A and ~A both link to ~A)"
 261                        class super (gethash link table) link))
 262               (setf (gethash link table) super))))
 263
 264         ;; Done.
 265         (values head chain
 266                 (cons chain
 267                       (mapcar #'sod-class-chain
 268                               (remove-if (lambda (super)
 269                                            (gethash super table))
 270                                          (cdr class-precedence-list)))))))))
 271
 272 ;;;--------------------------------------------------------------------------
 273 ;;; Sanity checking.
 274
 275 (defmethod check-sod-class ((class sod-class))
 276   (with-default-error-location (class)
 277
 278     ;; Check the names of things are valid.
 279     (with-slots (name nickname messages) class
 280       (unless (valid-name-p name)
 281         (error "Invalid class name `~A'" class))
 282       (unless (valid-name-p nickname)
 283         (error "Invalid class nickname `~A' on class `~A'" nickname class))
 284       (dolist (message messages)
 285         (unless (valid-name-p (sod-message-name message))
 286           (error "Invalid message name `~A' on class `~A'"
 287                  (sod-message-name message) class))))
 288
 289     ;; Check that the slots and messages have distinct names.
 290     (with-slots (slots messages class-precedence-list) class
 291       (flet ((check-list (list what namefunc)
 292                (let ((table (make-hash-table :test #'equal)))
 293                  (dolist (item list)
 294                    (let ((name (funcall namefunc item)))
 295                      (if (gethash name table)
 296                          (error "Duplicate ~A name `~A' on class `~A'"
 297                                 what name class)
 298                          (setf (gethash name table) item)))))))
 299         (check-list slots "slot" #'sod-slot-name)
 300         (check-list messages "message" #'sod-message-name)
 301         (check-list class-precedence-list "nickname" #'sod-class-name)))
 302
 303     ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
 304     ;; eliminates hairy things like a class being its own link.)
 305     (with-slots (class-precedence-list chain-link) class
 306       (unless (or (not chain-link)
 307                   (member chain-link (cdr class-precedence-list)))
 308         (error "In `~A~, chain-to class `~A' is not a proper superclass"
 309                class chain-link)))
 310
 311     ;; Check for circularity in the superclass graph.  Since the superclasses
 312     ;; should already be acyclic, it suffices to check that our class is not
 313     ;; a superclass of any of its own direct superclasses.
 314     (let ((circle (find-if (lambda (super)
 315                              (sod-subclass-p super class))
 316                            (sod-class-direct-superclasses class))))
 317       (when circle
 318         (error "Circularity: ~A is already a superclass of ~A"
 319                class circle)))
 320
 321     ;; Check that the class has a unique root superclass.
 322     (find-root-superclass class)
 323
 324     ;; Check that the metaclass is a subclass of each direct superclass's
 325     ;; metaclass.
 326     (with-slots (metaclass direct-superclasses) class
 327       (dolist (super direct-superclasses)
 328         (unless (sod-subclass-p metaclass (sod-class-metaclass super))
 329           (error "Incompatible metaclass for `~A': ~
 330                   `~A' isn't a subclass of `~A' (of `~A')"
 331                  class metaclass (sod-class-metaclass super) super))))))
 332
 333 ;;;--------------------------------------------------------------------------
 334 ;;; Finalization.
 335
 336 (defmethod finalize-sod-class ((class sod-class))
 337
 338   ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
 339   ;; clone of the CPL and chain establishment code.  If the interface changes
 340   ;; then `bootstrap-classes' will need to be changed too.
 341
 342   (with-default-error-location (class)
 343     (ecase (sod-class-state class)
 344       ((nil)
 345
 346        ;; If this fails, mark the class as a loss.
 347        (setf (sod-class-state class) :broken)
 348
 349        ;; Finalize all of the superclasses.  There's some special pleading
 350        ;; here to make bootstrapping work: we don't try to finalize the
 351        ;; metaclass if we're a root class (no direct superclasses -- because
 352        ;; in that case the metaclass will have to be a subclass of us!), or
 353        ;; if it's equal to us.  This is enough to tie the knot at the top of
 354        ;; the class graph.
 355        (with-slots (name direct-superclasses metaclass) class
 356          (dolist (super direct-superclasses)
 357            (finalize-sod-class super))
 358          (unless (or (null direct-superclasses)
 359                      (eq class metaclass))
 360            (finalize-sod-class metaclass)))
 361
 362        ;; Stash the class's type.
 363        (setf (sod-class-type class)
 364              (make-class-type (sod-class-name class)))
 365
 366        ;; Clobber the lists of items if they've not been set.
 367        (dolist (slot '(slots instance-initializers class-initializers
 368                        messages methods))
 369          (unless (slot-boundp class slot)
 370            (setf (slot-value class slot) nil)))
 371
 372        ;; If the CPL hasn't been done yet, compute it.
 373        (with-slots (class-precedence-list) class
 374          (unless (slot-boundp class 'class-precedence-list)
 375            (setf class-precedence-list (compute-cpl class))))
 376
 377        ;; Check that the class is fairly sane.
 378        (check-sod-class class)
 379
 380        ;; Determine the class's layout.
 381        (with-slots (chain-head chain chains) class
 382          (setf (values chain-head chain chains) (compute-chains class)))
 383
 384        ;; Done.
 385        (setf (sod-class-state class) :finalized)
 386        t)
 387
 388       (:broken
 389        nil)
 390
 391       (:finalized
 392        t))))
 393
 394 ;;;----- That's all, folks --------------------------------------------------