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 Sensible 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 (export 'clos-cpl)
 104 (defun clos-cpl (class)
 105   "Compute the class precedence list of CLASS using CLOS linearization rules.
 106
 107    We merge the direct-superclass lists of all of CLASS's superclasses,
 108    disambiguating using `clos-tiebreaker'.
 109
 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."
 114
 115   (labels ((superclasses (class)
 116              (let ((direct-supers (sod-class-direct-superclasses class)))
 117                (remove-duplicates (cons class
 118                                         (mappend #'superclasses
 119                                                  direct-supers))))))
 120     (merge-lists (mapcar (lambda (class)
 121                            (cons class
 122                                  (sod-class-direct-superclasses class)))
 123                          (superclasses class))
 124                  :pick #'clos-tiebreaker)))
 125
 126 (export 'dylan-cpl)
 127 (defun dylan-cpl (class)
 128   "Compute the class precedence list of CLASS using Dylan linearization
 129    rules.
 130
 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.)
 136
 137    The Dylan linearization preserves local class ordering and is monotonic,
 138    but does not respect the extended precedence graph.
 139
 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."
 144
 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)))
 149
 150 (export 'c3-cpl)
 151 (defun c3-cpl (class)
 152   "Compute the class precedence list of CLASS using C3 linearization rules.
 153
 154    We merge the direct-superclass list of CLASS with the full class
 155    precedence lists of its direct superclasses, disambiguating using
 156    `c3-tiebreaker'.
 157
 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
 161    for SOD."
 162
 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)))))
 169
 170 (export 'flavors-cpl)
 171 (defun flavors-cpl (class)
 172   "Compute the class precedence list of CLASS using Flavors linearization
 173    rules.
 174
 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.
 179
 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."
 183
 184   (let ((done nil))
 185     (labels ((walk (class)
 186                (unless (member class done)
 187                  (push class done)
 188                  (dolist (super (sod-class-direct-superclasses class))
 189                    (walk super)))))
 190       (walk class)
 191       (nreverse done))))
 192
 193 (export 'python-cpl)
 194 (defun python-cpl (class)
 195   "Compute the class precedence list of CLASS using the documented Python 2.2
 196    linearization rules.
 197
 198    We do a depth-first traversal of the superclass graph, retaining only the
 199    last occurrence of each class visited.
 200
 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."
 204
 205   (let ((done nil))
 206     (labels ((walk (class)
 207                (push class done)
 208                (dolist (super (sod-class-direct-superclasses class))
 209                  (walk super))))
 210       (walk class)
 211       (delete-duplicates (nreverse done)))))
 212
 213 (export 'l*loops-cpl)
 214 (defun l*loops-cpl (class)
 215   "Compute the class precedence list of CLASS using L*LOOPS linearization
 216    rules.
 217
 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.
 221
 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."
 225
 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))
 231                                      (dolist (class dfs)
 232                                        (when (member class candidates)
 233                                          (return class))))))))
 234
 235 ;;; Default function.
 236
 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)))))
 242
 243 ;;;--------------------------------------------------------------------------
 244 ;;; Chains.
 245
 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)
 251                        class))
 252              (chain (cons class (and chain-link
 253                                      (sod-class-chain chain-link))))
 254              (table (make-hash-table)))
 255
 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)))
 263             (when link
 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))))
 269
 270         ;; Done.
 271         (values head chain
 272                 (cons chain
 273                       (mapcar #'sod-class-chain
 274                               (remove-if (lambda (super)
 275                                            (gethash super table))
 276                                          (cdr class-precedence-list)))))))))
 277
 278 ;;;--------------------------------------------------------------------------
 279 ;;; Sanity checking.
 280
 281 (defmethod check-sod-class ((class sod-class))
 282   (with-default-error-location (class)
 283
 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))))
 294
 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)))
 299                  (dolist (item list)
 300                    (let ((name (funcall namefunc item)))
 301                      (if (gethash name table)
 302                          (error "Duplicate ~A name `~A' on class `~A'"
 303                                 what name class)
 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)))
 308
 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"
 315                class chain-link)))
 316
 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))))
 323       (when circle
 324         (error "Circularity: ~A is already a superclass of ~A"
 325                class circle)))
 326
 327     ;; Check that the class has a unique root superclass.
 328     (find-root-superclass class)
 329
 330     ;; Check that the metaclass is a subclass of each direct superclass's
 331     ;; metaclass.
 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))))))
 338
 339 ;;;--------------------------------------------------------------------------
 340 ;;; Finalization.
 341
 342 (defmethod finalize-sod-class ((class sod-class))
 343
 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.
 347
 348   (with-default-error-location (class)
 349     (ecase (sod-class-state class)
 350       ((nil)
 351
 352        ;; If this fails, mark the class as a loss.
 353        (setf (slot-value class 'state) :broken)
 354
 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
 360        ;; the class graph.
 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)))
 367
 368        ;; Stash the class's type.
 369        (setf (slot-value class '%type)
 370              (make-class-type (sod-class-name class)))
 371
 372        ;; Clobber the lists of items if they've not been set.
 373        (dolist (slot '(slots instance-initializers class-initializers
 374                        messages methods))
 375          (unless (slot-boundp class slot)
 376            (setf (slot-value class slot) nil)))
 377
 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))))
 382
 383        ;; Check that the class is fairly sane.
 384        (check-sod-class class)
 385
 386        ;; Determine the class's layout.
 387        (with-slots (chain-head chain chains) class
 388          (setf (values chain-head chain chains) (compute-chains class)))
 389
 390        ;; Done.
 391        (setf (slot-value class 'state) :finalized)
 392        t)
 393
 394       (:broken
 395        nil)
 396
 397       (:finalized
 398        t))))
 399
 400 (macrolet ((define-layout-slot (slot (class) &body body)
 401              `(define-on-demand-slot sod-class ,slot (,class)
 402                 (check-class-is-finalized ,class)
 403                 ,@body)))
 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))))
 413
 414 ;;;----- That's all, folks --------------------------------------------------