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 ;;; Utilities.
  52
  53 (export 'merge-class-lists)
  54 (defun merge-class-lists (lists pick)
  55   "Merge the LISTS of classes, using PICK to break ties.
  56
  57    This is a convenience wrapper around the main `merge-lists' function.
  58    Given that class linearizations (almost?) always specify a custom
  59    tiebreaker function, this isn't a keyword argument.  Also, this wrapper
  60    provides a standard presentation function so that any errors are presented
  61    properly."
  62   (merge-lists lists
  63                :pick pick
  64                :present (lambda (class)
  65                           (format nil "`~A'" (sod-class-name class)))))
  66
  67 ;;; Tiebreaker functions.
  68
  69 (defun clos-tiebreaker (candidates so-far)
  70   "The CLOS linearization tiebreaker function.
  71
  72    Intended for use with `merge-lists'.  Returns the member of CANDIDATES
  73    which has a direct subclass furthest to the right in the list SO-FAR.
  74
  75    This must disambiguate.  The SO-FAR list cannot be empty, since the class
  76    under construction precedes all of the others.  If two classes share a
  77    direct subclass then that subclass's direct superclasses list must order
  78    them relative to each other."
  79
  80   (let (winner)
  81     (dolist (class so-far)
  82       (dolist (candidate candidates)
  83         (when (member candidate (sod-class-direct-superclasses class))
  84           (setf winner candidate))))
  85     (unless winner
  86       (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
  87     winner))
  88
  89 (defun c3-tiebreaker (candidates cpls)
  90   "The C3 linearization tiebreaker function.
  91
  92    Intended for use with `merge-lists'.  Returns the member of CANDIDATES
  93    which appears in the earliest element of CPLS, which should be the list of
  94    the class precedence lists of the direct superclasses of the class in
  95    question, in the order specified in the class declaration.
  96
  97    The only class in the class precedence list which does not appear in one
  98    of these lists is the new class itself, which must precede all of the
  99    others.
 100
 101    This must disambiguate, since if two classes are in the same class
 102    precedence list, then one must appear in it before the other, which
 103    provides an ordering between them.  (In this situation we return the one
 104    that matches earliest anyway, which would still give the right answer.)
 105
 106    Note that this will merge the CPLs of superclasses /as they are/, not
 107    necessarily as C3 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   (dolist (cpl cpls)
 112     (dolist (candidate candidates)
 113       (when (member candidate cpl)
 114         (return-from c3-tiebreaker candidate))))
 115   (error "SOD INTERNAL ERROR: Failed to break tie in C3"))
 116
 117 ;;; Linearization functions.
 118
 119 (export 'clos-cpl)
 120 (defun clos-cpl (class)
 121   "Compute the class precedence list of CLASS using CLOS linearization rules.
 122
 123    We merge the direct-superclass lists of all of CLASS's superclasses,
 124    disambiguating using `clos-tiebreaker'.
 125
 126    The CLOS linearization preserves local class ordering, but is not
 127    monotonic, and does not respect the extended precedence graph.  CLOS
 128    linearization will succeed whenever Dylan or C3 linearization succeeds;
 129    the converse is not true."
 130
 131   (labels ((superclasses (class)
 132              (let ((direct-supers (sod-class-direct-superclasses class)))
 133                (remove-duplicates (cons class
 134                                         (mappend #'superclasses
 135                                                  direct-supers))))))
 136     (merge-class-lists
 137      (mapcar (lambda (class)
 138                (cons class (sod-class-direct-superclasses class)))
 139              (superclasses class))
 140      #'clos-tiebreaker)))
 141
 142 (export 'dylan-cpl)
 143 (defun dylan-cpl (class)
 144   "Compute the class precedence list of CLASS using Dylan linearization
 145    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    `clos-tiebreaker'.  (Inductively, these lists will be consistent with the
 150    CPLs of indirect superclasses, since those CPLs' orderings are reflected
 151    in the CPLs of the direct superclasses.)
 152
 153    The Dylan linearization preserves local class ordering and is monotonic,
 154    but does not respect the extended precedence graph.
 155
 156    Note that this will merge the CPLs of superclasses /as they are/, not
 157    necessarily as Dylan would have computed them.  This ensures monotonicity
 158    assuming that the superclass CPLs are already monotonic.  If they aren't,
 159    you're going to lose anyway."
 160
 161   (let ((direct-supers (sod-class-direct-superclasses class)))
 162     (merge-class-lists
 163      (cons (cons class direct-supers)
 164            (mapcar #'sod-class-precedence-list direct-supers))
 165      #'clos-tiebreaker)))
 166
 167 (export 'c3-cpl)
 168 (defun c3-cpl (class)
 169   "Compute the class precedence list of CLASS using C3 linearization rules.
 170
 171    We merge the direct-superclass list of CLASS with the full class
 172    precedence lists of its direct superclasses, disambiguating using
 173    `c3-tiebreaker'.
 174
 175    The C3 linearization preserves local class ordering, is monotonic, and
 176    respects the extended precedence graph.  It is the linearization used in
 177    Python, Perl 6 and other languages.  It is the recommended linearization
 178    for SOD."
 179
 180   (let* ((direct-supers (sod-class-direct-superclasses class))
 181          (cpls (mapcar #'sod-class-precedence-list direct-supers)))
 182     (merge-class-lists (cons (cons class direct-supers) cpls)
 183                        (lambda (candidates so-far)
 184                          (declare (ignore so-far))
 185                          (c3-tiebreaker candidates cpls)))))
 186
 187 (export 'flavors-cpl)
 188 (defun flavors-cpl (class)
 189   "Compute the class precedence list of CLASS using Flavors linearization
 190    rules.
 191
 192    We do a depth-first traversal of the superclass graph, ignoring duplicates
 193    of classes we've already visited.  Interestingly, this has the property of
 194    being able to tolerate cyclic superclass graphs, though defining cyclic
 195    graphs is syntactically impossible in SOD.
 196
 197    This linearization has few other redeeming features, however.  In
 198    particular, the top class tends not to be at the end of the CPL, despite
 199    it being unequivocally less specific than any other class."
 200
 201   (let ((done nil))
 202     (labels ((walk (class)
 203                (unless (member class done)
 204                  (push class done)
 205                  (dolist (super (sod-class-direct-superclasses class))
 206                    (walk super)))))
 207       (walk class)
 208       (nreverse done))))
 209
 210 (export 'python-cpl)
 211 (defun python-cpl (class)
 212   "Compute the class precedence list of CLASS using the documented Python 2.2
 213    linearization rules.
 214
 215    We do a depth-first traversal of the superclass graph, retaining only the
 216    last occurrence of each class visited.
 217
 218    This linearization has few redeeming features.  It was never actually
 219    implemented; the true Python 2.2 linearization seems closer to (but
 220    different from) L*LOOPS."
 221
 222   (let ((done nil))
 223     (labels ((walk (class)
 224                (push class done)
 225                (dolist (super (sod-class-direct-superclasses class))
 226                  (walk super))))
 227       (walk class)
 228       (delete-duplicates (nreverse done)))))
 229
 230 (export 'l*loops-cpl)
 231 (defun l*loops-cpl (class)
 232   "Compute the class precedence list of CLASS using L*LOOPS linearization
 233    rules.
 234
 235    We merge the class precedence lists of the direct superclasses of CLASS,
 236    disambiguating by choosing the earliest candidate which appears in a
 237    depth-first walk of the superclass graph.
 238
 239    The L*LOOPS rules are monotonic and respect the extended precedence
 240    graph.  However (unlike Dylan and CLOS) they don't respect local
 241    precedence order i.e., the direct-superclasses list orderings."
 242
 243   (let ((dfs (flavors-cpl class)))
 244     (cons class
 245           (merge-class-lists (mapcar #'sod-class-precedence-list
 246                                      (sod-class-direct-superclasses class))
 247                              (lambda (candidates so-far)
 248                                (declare (ignore so-far))
 249                                (dolist (class dfs)
 250                                  (when (member class candidates)
 251                                    (return class))))))))
 252
 253 ;;; Default function.
 254
 255 (defmethod compute-cpl ((class sod-class))
 256   (handler-case (c3-cpl class)
 257     (inconsistent-merge-error ()
 258       (error "Failed to compute class precedence list for `~A'"
 259              (sod-class-name class)))))
 260
 261 ;;;--------------------------------------------------------------------------
 262 ;;; Chains.
 263
 264 (defmethod compute-chains ((class sod-class))
 265   (with-default-error-location (class)
 266     (with-slots (chain-link class-precedence-list) class
 267       (let* ((head (if chain-link
 268                        (sod-class-chain-head chain-link)
 269                        class))
 270              (chain (cons class (and chain-link
 271                                      (sod-class-chain chain-link))))
 272              (table (make-hash-table)))
 273
 274         ;; Check the chains.  We work through each superclass, maintaining a
 275         ;; hash table keyed by class.  If we encounter a class C which links
 276         ;; to L, then we store C as L's value; if L already has a value then
 277         ;; we've found an error.  By the end of all of this, the classes
 278         ;; which don't have an entry are the chain tails.
 279         (dolist (super class-precedence-list)
 280           (let ((link (sod-class-chain-link super)))
 281             (when link
 282               (when (gethash link table)
 283                 (error "Conflicting chains in class ~A: ~
 284                         (~A and ~A both link to ~A)"
 285                        class super (gethash link table) link))
 286               (setf (gethash link table) super))))
 287
 288         ;; Done.
 289         (values head chain
 290                 (cons chain
 291                       (mapcar #'sod-class-chain
 292                               (remove-if (lambda (super)
 293                                            (gethash super table))
 294                                          (cdr class-precedence-list)))))))))
 295
 296 ;;;--------------------------------------------------------------------------
 297 ;;; Metaclasses.
 298
 299 (defmethod guess-metaclass ((class sod-class))
 300   "Default metaclass-guessing function for classes.
 301
 302    Return the most specific metaclass of any of the CLASS's direct
 303    superclasses."
 304
 305   ;; During bootstrapping, our superclasses might not have their own
 306   ;; metaclasses resolved yet.  If we find this, then throw `bootstrapping'
 307   ;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
 308   ;; across the bows of anyone else who calls us).
 309   (select-minimal-class-property (sod-class-direct-superclasses class)
 310                                  (lambda (super)
 311                                    (if (slot-boundp super 'metaclass)
 312                                        (slot-value super 'metaclass)
 313                                        (throw 'bootstrapping nil)))
 314                                  #'sod-subclass-p class "metaclass"))
 315
 316 ;;;--------------------------------------------------------------------------
 317 ;;; Sanity checking.
 318
 319 (defmethod check-sod-class ((class sod-class))
 320   (with-default-error-location (class)
 321
 322     ;; Check the names of things are valid.
 323     (with-slots (name nickname messages) class
 324       (unless (valid-name-p name)
 325         (error "Invalid class name `~A'" class))
 326       (unless (valid-name-p nickname)
 327         (error "Invalid class nickname `~A' on class `~A'" nickname class))
 328       (dolist (message messages)
 329         (unless (valid-name-p (sod-message-name message))
 330           (error "Invalid message name `~A' on class `~A'"
 331                  (sod-message-name message) class))))
 332
 333     ;; Check that the slots and messages have distinct names.
 334     (with-slots (slots messages class-precedence-list) class
 335       (flet ((check-list (list what namefunc)
 336                (let ((table (make-hash-table :test #'equal)))
 337                  (dolist (item list)
 338                    (let ((name (funcall namefunc item)))
 339                      (if (gethash name table)
 340                          (error "Duplicate ~A name `~A' on class `~A'"
 341                                 what name class)
 342                          (setf (gethash name table) item)))))))
 343         (check-list slots "slot" #'sod-slot-name)
 344         (check-list messages "message" #'sod-message-name)
 345         (check-list class-precedence-list "nickname" #'sod-class-name)))
 346
 347     ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
 348     ;; eliminates hairy things like a class being its own link.)
 349     (with-slots (class-precedence-list chain-link) class
 350       (unless (or (not chain-link)
 351                   (member chain-link (cdr class-precedence-list)))
 352         (error "In `~A~, chain-to class `~A' is not a proper superclass"
 353                class chain-link)))
 354
 355     ;; Check that the initargs declare compatible types.  Duplicate entries,
 356     ;; even within a class, are harmless, but at most one initarg in any
 357     ;; class should declare a default value.
 358     (with-slots (class-precedence-list) class
 359       (let ((seen (make-hash-table :test #'equal)))
 360         (dolist (super class-precedence-list)
 361           (with-slots (initargs) super
 362             (dolist (initarg (reverse initargs))
 363               (let* ((initarg-name (sod-initarg-name initarg))
 364                      (initarg-type (sod-initarg-type initarg))
 365                      (initarg-default (sod-initarg-default initarg))
 366                      (found (gethash initarg-name seen))
 367                      (found-type (and found (sod-initarg-type found)))
 368                      (found-default (and found (sod-initarg-default found)))
 369                      (found-class (and found (sod-initarg-class found)))
 370                      (found-location (and found (file-location found))))
 371                 (with-default-error-location (initarg)
 372                   (cond ((not found)
 373                          (setf (gethash initarg-name seen) initarg))
 374                         ((not (c-type-equal-p initarg-type found-type))
 375                          (cerror* "Inititalization argument `~A' defined ~
 376                                    with incompatible types: ~
 377                                    ~A in class ~A, and ~
 378                                    ~A in class ~A (at ~A)"
 379                                 initarg-name initarg-type super
 380                                 found-type found-class found-location))
 381                         ((and initarg-default found-default
 382                               (eql super found-class))
 383                          (cerror* "Initialization argument `~A' redefined ~
 384                                    with default value ~
 385                                    (previous definition at ~A)"
 386                                   initarg-name found-location))
 387                         (initarg-default
 388                          (setf (gethash initarg-name seen) initarg))))))))))
 389
 390     ;; Check for circularity in the superclass graph.  Since the superclasses
 391     ;; should already be acyclic, it suffices to check that our class is not
 392     ;; a superclass of any of its own direct superclasses.
 393     (let ((circle (find-if (lambda (super)
 394                              (sod-subclass-p super class))
 395                            (sod-class-direct-superclasses class))))
 396       (when circle
 397         (error "Circularity: ~A is already a superclass of ~A"
 398                class circle)))
 399
 400     ;; Check that the class has a unique root superclass.
 401     (find-root-superclass class)
 402
 403     ;; Check that the metaclass is a subclass of each direct superclass's
 404     ;; metaclass.
 405     (with-slots (metaclass direct-superclasses) class
 406       (dolist (super direct-superclasses)
 407         (unless (sod-subclass-p metaclass (sod-class-metaclass super))
 408           (error "Incompatible metaclass for `~A': ~
 409                   `~A' isn't a subclass of `~A' (of `~A')"
 410                  class metaclass (sod-class-metaclass super) super))))))
 411
 412 ;;;--------------------------------------------------------------------------
 413 ;;; Finalization.
 414
 415 (defmethod finalize-sod-class :around ((class sod-class))
 416   "Common functionality for `finalize-sod-class'.
 417
 418      * If an attempt to finalize the CLASS has been made before, then we
 419        don't try again.  Similarly, attempts to finalize a class recursively
 420        will fail.
 421
 422      * A condition handler is established to keep track of whether any errors
 423        are signalled during finalization.  The CLASS is only marked as
 424        successfully finalized if no (unhandled) errors are encountered."
 425   (with-default-error-location (class)
 426     (ecase (sod-class-state class)
 427       ((nil)
 428
 429        ;; If this fails, leave the class marked as a loss.
 430        (setf (slot-value class 'state) :broken)
 431
 432        ;; Invoke the finalization method proper.
 433        (call-next-method)
 434        (setf (slot-value class 'state) :finalized)
 435        t)
 436
 437       ;; If the class is broken, we're not going to be able to fix it now.
 438       (:broken
 439        nil)
 440
 441       ;; If we already finalized it, there's no point doing it again.
 442       (:finalized
 443        t))))
 444
 445 (defmethod finalize-sod-class ((class sod-class))
 446
 447   ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
 448   ;; clone of the CPL and chain establishment code.  If the interface changes
 449   ;; then `bootstrap-classes' will need to be changed too.
 450
 451   ;; Set up the metaclass if it's not been set already.  This is delayed
 452   ;; to give bootstrapping a chance to set up metaclass and superclass
 453   ;; circularities.
 454   (default-slot (class 'metaclass) (guess-metaclass class))
 455
 456   ;; Finalize all of the superclasses.  There's some special pleading here to
 457   ;; make bootstrapping work: we don't try to finalize the metaclass if we're
 458   ;; a root class (no direct superclasses -- because in that case the
 459   ;; metaclass will have to be a subclass of us!), or if it's equal to us.
 460   ;; This is enough to tie the knot at the top of the class graph.
 461   (with-slots (name direct-superclasses metaclass) class
 462     (dolist (super direct-superclasses)
 463       (finalize-sod-class super))
 464     (unless (or (null direct-superclasses)
 465                 (eq class metaclass))
 466       (finalize-sod-class metaclass)))
 467
 468   ;; Stash the class's type.
 469   (setf (slot-value class '%type)
 470         (make-class-type (sod-class-name class)))
 471
 472   ;; Clobber the lists of items if they've not been set.
 473   (dolist (slot '(slots instance-initializers class-initializers
 474                   messages methods))
 475     (unless (slot-boundp class slot)
 476       (setf (slot-value class slot) nil)))
 477
 478   ;; If the CPL hasn't been done yet, compute it.
 479   (with-slots (class-precedence-list) class
 480     (unless (slot-boundp class 'class-precedence-list)
 481       (setf class-precedence-list (compute-cpl class))))
 482
 483   ;; Check that the class is fairly sane.
 484   (check-sod-class class)
 485
 486   ;; Determine the class's layout.
 487   (setf (values (slot-value class 'chain-head)
 488                 (slot-value class 'chain)
 489                 (slot-value class 'chains))
 490         (compute-chains class)))
 491
 492 ;;;----- That's all, folks --------------------------------------------------