mdw@git.distorted.org.uk Git - 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 'report-class-list-merge-error)
  54 (defun report-class-list-merge-error (class lists error)
  55   "Report a failure to merge superclasseses.
  56
  57    Here, CLASS is the class whose class precedence list we're trying to
  58    compute; the LISTS are the individual superclass orderings being merged;
  59    and ERROR is an `inconsistent-merge-error' describing the problem that was
  60    encountered.
  61
  62    Each of the LISTS is assumed to begin with the class from which the
  63    corresponding constraint originates; see `merge-class-lists'."
  64
  65   (let* ((state (make-inheritance-path-reporter-state class))
  66          (candidates (merge-error-candidates error))
  67          (focus (remove-duplicates
  68                  (remove nil
  69                          (mapcar (lambda (list)
  70                                    (cons (car list)
  71                                          (remove-if-not
  72                                           (lambda (item)
  73                                             (member item candidates))
  74                                           list)))
  75                                  lists)
  76                          :key #'cddr)
  77                  :test #'equal :key #'cdr)))
  78
  79     (cerror*-with-location class "Ill-formed superclass graph: ~
  80                                   can't construct class precedence list ~
  81                                   for `~A'"
  82                            class)
  83     (dolist (offenders focus)
  84       (let ((super (car offenders)))
  85         (info-with-location super
  86                             "~{Class `~A' orders `~A' before ~
  87                                ~#[<BUG>~;`~A'~;`~A' and `~A'~:;~
  88                                   ~@{`~A', ~#[~;and `~A'~]~}~]~}"
  89                             offenders)
  90         (report-inheritance-path state super)))))
  91
  92 (export 'merge-class-lists)
  93 (defun merge-class-lists (class lists pick)
  94   "Merge the LISTS of superclasses of CLASS, using PICK to break ties.
  95
  96    This is a convenience wrapper around the main `merge-lists' function.
  97    Given that class linearizations (almost?) always specify a custom
  98    tiebreaker function, this isn't a keyword argument.
  99
 100    If a merge error occurs, this function translates it into a rather more
 101    useful form, and tries to provide helpful notes.
 102
 103    For error reporting purposes, it's assumed that each of the LISTS begins
 104    with the class from which the corresponding constraint originates.  This
 105    initial class does double-duty: it is also considered to be part of the
 106    list for the purpose of the merge."
 107
 108   (handler-case (merge-lists lists :pick pick)
 109     (inconsistent-merge-error (error)
 110       (report-class-list-merge-error class lists error)
 111       (continue error))))
 112
 113 ;;; Tiebreaker functions.
 114
 115 (defun clos-tiebreaker (candidates so-far)
 116   "The CLOS linearization tiebreaker function.
 117
 118    Intended for use with `merge-lists'.  Returns the member of CANDIDATES
 119    which has a direct subclass furthest to the right in the list SO-FAR.
 120
 121    This must disambiguate.  The SO-FAR list cannot be empty, since the class
 122    under construction precedes all of the others.  If two classes share a
 123    direct subclass then that subclass's direct superclasses list must order
 124    them relative to each other."
 125
 126   (dolist (class (reverse so-far))
 127     (dolist (candidate candidates)
 128       (when (member candidate (sod-class-direct-superclasses class))
 129         (return-from clos-tiebreaker candidate))))
 130   (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
 131
 132 (defun c3-tiebreaker (candidates cpls)
 133   "The C3 linearization tiebreaker function.
 134
 135    Intended for use with `merge-lists'.  Returns the member of CANDIDATES
 136    which appears in the earliest element of CPLS, which should be the list of
 137    the class precedence lists of the direct superclasses of the class in
 138    question, in the order specified in the class declaration.
 139
 140    The only class in the class precedence list which does not appear in one
 141    of these lists is the new class itself, which must precede all of the
 142    others.
 143
 144    This must disambiguate, since if two classes are in the same class
 145    precedence list, then one must appear in it before the other, which
 146    provides an ordering between them.  (In this situation we return the one
 147    that matches earliest anyway, which would still give the right answer.)
 148
 149    Note that this will merge the CPLs of superclasses /as they are/, not
 150    necessarily as C3 would have computed them.  This ensures monotonicity
 151    assuming that the superclass CPLs are already monotonic.  If they aren't,
 152    you're going to lose anyway."
 153
 154   (dolist (cpl cpls)
 155     (dolist (candidate candidates)
 156       (when (member candidate cpl)
 157         (return-from c3-tiebreaker candidate))))
 158   (error "SOD INTERNAL ERROR: Failed to break tie in C3"))
 159
 160 ;;; Linearization functions.
 161
 162 (export 'clos-cpl)
 163 (defun clos-cpl (class)
 164   "Compute the class precedence list of CLASS using CLOS linearization rules.
 165
 166    We merge the direct-superclass lists of all of CLASS's superclasses,
 167    disambiguating using `clos-tiebreaker'.
 168
 169    The CLOS linearization preserves local class ordering, but is not
 170    monotonic, and does not respect the extended precedence graph.  CLOS
 171    linearization will succeed whenever Dylan or C3 linearization succeeds;
 172    the converse is not true."
 173
 174   (labels ((superclasses (class)
 175              (let ((direct-supers (sod-class-direct-superclasses class)))
 176                (remove-duplicates (cons class
 177                                         (mappend #'superclasses
 178                                                  direct-supers))))))
 179     (merge-class-lists class
 180                        (mapcar (lambda (c)
 181                                  (cons c (sod-class-direct-superclasses c)))
 182                                (superclasses class))
 183                        #'clos-tiebreaker)))
 184
 185 (export 'dylan-cpl)
 186 (defun dylan-cpl (class)
 187   "Compute the class precedence list of CLASS using Dylan linearization
 188    rules.
 189
 190    We merge the direct-superclass list of CLASS with the full class
 191    precedence lists of its direct superclasses, disambiguating using
 192    `clos-tiebreaker'.  (Inductively, these lists will be consistent with the
 193    CPLs of indirect superclasses, since those CPLs' orderings are reflected
 194    in the CPLs of the direct superclasses.)
 195
 196    The Dylan linearization preserves local class ordering and is monotonic,
 197    but does not respect the extended precedence graph.
 198
 199    Note that this will merge the CPLs of superclasses /as they are/, not
 200    necessarily as Dylan would have computed them.  This ensures monotonicity
 201    assuming that the superclass CPLs are already monotonic.  If they aren't,
 202    you're going to lose anyway."
 203
 204   (let* ((direct-supers (sod-class-direct-superclasses class))
 205          (cpls (mapcar #'sod-class-precedence-list direct-supers)))
 206     (merge-class-lists class
 207                        (cons (cons class direct-supers) cpls)
 208                        #'clos-tiebreaker)))
 209
 210 (export 'c3-cpl)
 211 (defun c3-cpl (class)
 212   "Compute the class precedence list of CLASS using C3 linearization rules.
 213
 214    We merge the direct-superclass list of CLASS with the full class
 215    precedence lists of its direct superclasses, disambiguating using
 216    `c3-tiebreaker'.
 217
 218    The C3 linearization preserves local class ordering, is monotonic, and
 219    respects the extended precedence graph.  It is the linearization used in
 220    Python, Perl 6 and other languages.  It is the recommended linearization
 221    for SOD."
 222
 223   (let* ((direct-supers (sod-class-direct-superclasses class))
 224          (cpls (mapcar #'sod-class-precedence-list direct-supers)))
 225     (merge-class-lists class
 226                        (cons (cons class direct-supers) cpls)
 227                        (lambda (candidates so-far)
 228                          (declare (ignore so-far))
 229                          (c3-tiebreaker candidates cpls)))))
 230
 231 (export 'flavors-cpl)
 232 (defun flavors-cpl (class)
 233   "Compute the class precedence list of CLASS using Flavors linearization
 234    rules.
 235
 236    We do a depth-first traversal of the superclass graph, ignoring duplicates
 237    of classes we've already visited.  Interestingly, this has the property of
 238    being able to tolerate cyclic superclass graphs, though defining cyclic
 239    graphs is syntactically impossible in SOD.
 240
 241    This linearization has few other redeeming features, however.  In
 242    particular, the top class tends not to be at the end of the CPL, despite
 243    it being unequivocally less specific than any other class."
 244
 245   (let ((done nil))
 246     (labels ((walk (class)
 247                (unless (member class done)
 248                  (push class done)
 249                  (dolist (super (sod-class-direct-superclasses class))
 250                    (walk super)))))
 251       (walk class)
 252       (nreverse done))))
 253
 254 (export 'python-cpl)
 255 (defun python-cpl (class)
 256   "Compute the class precedence list of CLASS using the documented Python 2.2
 257    linearization rules.
 258
 259    We do a depth-first traversal of the superclass graph, retaining only the
 260    last occurrence of each class visited.
 261
 262    This linearization has few redeeming features.  It was never actually
 263    implemented; the true Python 2.2 linearization seems closer to (but
 264    different from) L*LOOPS."
 265
 266   (let ((done nil))
 267     (labels ((walk (class)
 268                (push class done)
 269                (dolist (super (sod-class-direct-superclasses class))
 270                  (walk super))))
 271       (walk class)
 272       (delete-duplicates (nreverse done)))))
 273
 274 (export 'l*loops-cpl)
 275 (defun l*loops-cpl (class)
 276   "Compute the class precedence list of CLASS using L*LOOPS linearization
 277    rules.
 278
 279    We merge the class precedence lists of the direct superclasses of CLASS,
 280    disambiguating by choosing the earliest candidate which appears in a
 281    depth-first walk of the superclass graph.
 282
 283    The L*LOOPS rules are monotonic and respect the extended precedence
 284    graph.  However (unlike Dylan and CLOS) they don't respect local
 285    precedence order i.e., the direct-superclasses list orderings."
 286
 287   (let ((dfs (flavors-cpl class)))
 288     (cons class
 289           (merge-class-lists class
 290                              (mapcar #'sod-class-precedence-list
 291                                      (sod-class-direct-superclasses class))
 292                              (lambda (candidates so-far)
 293                                (declare (ignore so-far))
 294                                (dolist (class dfs)
 295                                  (when (member class candidates)
 296                                    (return class))))))))
 297
 298 ;;; Default function.
 299
 300 (defmethod compute-cpl ((class sod-class))
 301   (c3-cpl class))
 302
 303 ;;;--------------------------------------------------------------------------
 304 ;;; Chains.
 305
 306 (defmethod compute-chains ((class sod-class))
 307   (with-default-error-location (class)
 308     (with-slots (chain-link class-precedence-list) class
 309       (let* ((head (if chain-link
 310                        (sod-class-chain-head chain-link)
 311                        class))
 312              (chain (cons class (and chain-link
 313                                      (sod-class-chain chain-link))))
 314              (state (make-inheritance-path-reporter-state class))
 315              (table (make-hash-table)))
 316
 317         ;; Check the chains.  We work through each superclass, maintaining a
 318         ;; hash table keyed by class.  If we encounter a class C which links
 319         ;; to L, then we store C as L's value; if L already has a value then
 320         ;; we've found an error.  By the end of all of this, the classes
 321         ;; which don't have an entry are the chain tails.
 322         (dolist (super class-precedence-list)
 323           (let* ((link (sod-class-chain-link super))
 324                  (found (and link (gethash link table))))
 325             (cond ((not found) (setf (gethash link table) super))
 326                   (t
 327                    (cerror* "Conflicting chains in class `~A': ~
 328                              (`~A' and `~A' both link to `~A')"
 329                             class super found link)
 330                    (report-inheritance-path state super)
 331                    (report-inheritance-path state found)))))
 332
 333         ;; Done.
 334         (values head chain
 335                 (cons chain
 336                       (mapcar #'sod-class-chain
 337                               (remove-if (lambda (super)
 338                                            (gethash super table))
 339                                          (cdr class-precedence-list)))))))))
 340
 341 ;;;--------------------------------------------------------------------------
 342 ;;; Sanity checking.
 343
 344 (defmethod check-class-initializer ((slot effective-slot) (class sod-class))
 345   (finalization-error (:missing-class-initializer)
 346     (unless (find-class-initializer slot class)
 347       (let ((dslot (effective-slot-direct-slot slot)))
 348         (cerror* "Missing initializer for class slot `~A', ~
 349                   defined by meta-superclass `~A' of `~A'"
 350                  dslot (sod-slot-class dslot) class)))))
 351
 352 (defmethod check-class-initializer
 353     ((slot sod-class-effective-slot) (class sod-class))
 354   ;; The programmer shouldn't set an explicit initializer here.
 355   (finalization-error (:invalid-class-initializer)
 356     (let ((init (find-class-initializer slot class))
 357           (dslot (effective-slot-direct-slot slot)))
 358       (when init
 359         (cerror* "Initializers not permitted for class slot `~A', ~
 360                   defined by meta-superclass `~A' of `~A'"
 361                  dslot (sod-slot-class dslot) class)
 362         (info-with-location init "Offending initializer defined here")))))
 363
 364 (defmethod check-sod-class ((class sod-class))
 365
 366   ;; Check the names of things are valid.
 367   (flet ((check-list (list what namefunc)
 368            (dolist (item list)
 369              (let ((name (funcall namefunc item)))
 370                (unless (valid-name-p name)
 371                  (cerror*-with-location item
 372                                         "Invalid ~A name `~A' in class `~A'"
 373                                         what name class))))))
 374     (unless (valid-name-p (sod-class-name class))
 375       (cerror* "Invalid class name `~A'" class))
 376     (unless (valid-name-p (sod-class-nickname class))
 377       (cerror* "Invalid class nickname `~A' for class `~A'"
 378                (sod-class-nickname class) class))
 379     (check-list (sod-class-messages class) "message" #'sod-message-name)
 380     (check-list (sod-class-slots class) "slot" #'sod-slot-name))
 381
 382   ;; Check that the class doesn't define conflicting things.
 383   (labels ((simple-previous (previous)
 384              (info-with-location previous "Previous definition was here"))
 385            (simple-complain (what namefunc)
 386              (lambda (item previous)
 387                (cerror*-with-location item
 388                                       "Duplicate ~A `~A' in class `~A'"
 389                                       what (funcall namefunc item) class)
 390                (simple-previous previous))))
 391
 392     ;; Make sure direct slots have distinct names.
 393     (find-duplicates (simple-complain "slot name" #'sod-slot-name)
 394                      (sod-class-slots class)
 395                      :key #'sod-slot-name
 396                      :test #'equal)
 397
 398     ;; Make sure there's at most one initializer for each slot.
 399     (flet ((check-initializer-list (list kind)
 400              (find-duplicates (lambda (initializer previous)
 401                                 (let ((slot
 402                                        (sod-initializer-slot initializer)))
 403                                   (cerror*-with-location initializer
 404                                                          "Duplicate ~
 405                                                           initializer ~
 406                                                           for ~A slot `~A' ~
 407                                                           in class `~A'"
 408                                                          kind slot class)
 409                                   (simple-previous previous)))
 410                               list
 411                               :key #'sod-initializer-slot)))
 412       (check-initializer-list (sod-class-instance-initializers class)
 413                               "instance")
 414       (check-initializer-list (sod-class-class-initializers class)
 415                               "class"))
 416
 417     ;; Make sure messages have distinct names.
 418     (find-duplicates (simple-complain "message name" #'sod-message-name)
 419                      (sod-class-messages class)
 420                      :key #'sod-message-name
 421                      :test #'equal)
 422
 423     ;; Make sure methods are sufficiently distinct.
 424     (find-duplicates (lambda (method previous)
 425                        (cerror*-with-location method
 426                                               "Duplicate ~A direct method ~
 427                                                for message `~A' ~
 428                                                in classs `~A'"
 429                                               (sod-method-description method)
 430                                               (sod-method-message method)
 431                                               class)
 432                        (simple-previous previous))
 433                      (sod-class-methods class)
 434                      :key #'sod-method-function-name
 435                      :test #'equal)
 436
 437     ;; Make sure superclasses have distinct nicknames.
 438     (let ((state (make-inheritance-path-reporter-state class)))
 439       (find-duplicates (lambda (super previous)
 440                          (cerror*-with-location class
 441                                                 "Duplicate nickname `~A' ~
 442                                                  in superclasses of `~A': ~
 443                                                  used by `~A' and `~A'"
 444                                                 (sod-class-nickname super)
 445                                                 class super previous)
 446                          (report-inheritance-path state super)
 447                          (report-inheritance-path state previous))
 448                        (sod-class-precedence-list class)
 449                        :key #'sod-class-nickname :test #'equal)))
 450
 451   ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
 452   ;; eliminates hairy things like a class being its own link.)
 453   (let ((link (sod-class-chain-link class)))
 454     (unless (or (not link)
 455                 (member link (cdr (sod-class-precedence-list class))))
 456       (cerror* "In `~A', chain-to class `~A' is not a proper superclass"
 457                class link)))
 458
 459   ;; Check that the initargs declare compatible types.  Duplicate entries,
 460   ;; even within a class, are harmless, but at most one initarg in any
 461   ;; class should declare a default value.
 462   (let ((seen (make-hash-table :test #'equal))
 463         (state (make-inheritance-path-reporter-state class)))
 464     (dolist (super (sod-class-precedence-list class))
 465       (dolist (initarg (reverse (sod-class-initargs super)))
 466         (let* ((initarg-name (sod-initarg-name initarg))
 467                (initarg-type (sod-initarg-type initarg))
 468                (initarg-default (sod-initarg-default initarg))
 469                (found (gethash initarg-name seen))
 470                (found-type (and found (sod-initarg-type found)))
 471                (found-default (and found (sod-initarg-default found)))
 472                (found-class (and found (sod-initarg-class found)))
 473                (found-location (and found (file-location found))))
 474           (with-default-error-location (initarg)
 475             (cond ((not found)
 476                    (setf (gethash initarg-name seen) initarg))
 477                   ((not (c-type-equal-p initarg-type found-type))
 478                    (cerror* "Inititalization argument `~A' defined ~
 479                              with incompatible types: ~
 480                              ~A in class `~A', but ~A in class `~A'"
 481                             initarg-name initarg-type super
 482                             found-type found-class found-location)
 483                    (report-inheritance-path state super))
 484                   ((and initarg-default found-default
 485                         (eql super found-class))
 486                    (cerror* "Initialization argument `~A' redefined ~
 487                              with default value"
 488                             initarg-name)
 489                    (info-with-location found-location
 490                                        "Previous definition is here"))
 491                   (initarg-default
 492                    (setf (gethash initarg-name seen) initarg))))))))
 493
 494   ;; Check for circularity in the superclass graph.  Since the superclasses
 495   ;; should already be acyclic, it suffices to check that our class is not
 496   ;; a superclass of any of its own direct superclasses.
 497   (let ((circle (find-if (lambda (super)
 498                            (sod-subclass-p super class))
 499                          (sod-class-direct-superclasses class))))
 500     (when circle
 501       (cerror* "`~A' is already a superclass of `~A'" class circle)
 502       (report-inheritance-path (make-inheritance-path-reporter-state class)
 503                                circle)))
 504
 505   ;; Check that the class has a unique root superclass.
 506   (find-root-superclass class)
 507
 508   ;; Check that the metaclass is a subclass of each direct superclass's
 509   ;; metaclass.
 510   (finalization-error (:bad-metaclass)
 511     (let ((meta (sod-class-metaclass class)))
 512       (dolist (super (sod-class-direct-superclasses class))
 513         (let ((supermeta (sod-class-metaclass super)))
 514           (unless (sod-subclass-p meta supermeta)
 515             (cerror* "Metaclass `~A' of `~A' isn't a subclass of `~A'"
 516                      meta class supermeta)
 517             (info-with-location super
 518                                 "Direct superclass `~A' defined here ~
 519                                  has metaclass `~A'"
 520                                 super supermeta))))))
 521
 522   ;; Check that all of the messages we can be sent have coherent collections
 523   ;; of applicable methods.  This can go wrong, for example, if we inherit
 524   ;; methods with differently typed keyword arguments.
 525   (finalization-error (:mismatched-applicable-methods)
 526     (dolist (super (sod-class-precedence-list class))
 527       (dolist (message (sod-class-messages super))
 528         (let ((methods (sod-message-applicable-methods message class)))
 529           (sod-message-check-methods message class methods)))))
 530
 531   ;; Check that an initializer is available for every slot in the class's
 532   ;; metaclass.  Skip this and trust the caller if the metaclass isn't
 533   ;; finalized yet: in that case, we must be bootstrapping, and we must hope
 534   ;; that the caller knows what they're doing.
 535   (let* ((meta (sod-class-metaclass class))
 536          (ilayout (and (eq (sod-class-state meta) :finalized)
 537                        (sod-class-ilayout meta))))
 538     (dolist (ichain (and ilayout (ilayout-ichains ilayout)))
 539       (dolist (item (cdr (ichain-body ichain)))
 540         (when (typep item 'islots)
 541           (dolist (slot (islots-slots item))
 542             (check-class-initializer slot class)))))))
 543
 544 ;;;--------------------------------------------------------------------------
 545 ;;; Finalization.
 546
 547 (defmethod finalize-sod-class :around ((class sod-class))
 548   "Common functionality for `finalize-sod-class'.
 549
 550      * If an attempt to finalize the CLASS has been made before, then we
 551        don't try again.  Similarly, attempts to finalize a class recursively
 552        will fail.
 553
 554      * A condition handler is established to keep track of whether any errors
 555        are signalled during finalization.  The CLASS is only marked as
 556        successfully finalized if no (unhandled) errors are encountered."
 557   (with-default-error-location (class)
 558     (ecase (sod-class-state class)
 559       ((nil)
 560
 561        ;; If this fails, leave the class marked as a loss.
 562        (setf (slot-value class 'state) :broken)
 563
 564        ;; Invoke the finalization method proper.  If it signals any
 565        ;; continuable errors, take note of them so that we can report failure
 566        ;; properly.
 567        ;;
 568        ;; Catch: we get called recursively to clean up superclasses and
 569        ;; metaclasses, but there should only be one such handler, so don't
 570        ;; add another.  (In turn, this means that other methods mustn't
 571        ;; actually trap their significant errors.)
 572        (let ((have-handler-p (boundp '*finalization-errors*))
 573              (*finalization-errors* nil)
 574              (*finalization-error-token* nil))
 575          (catch '%finalization-failed
 576            (if have-handler-p (call-next-method)
 577                (handler-bind ((error (lambda (cond)
 578                                        (declare (ignore cond))
 579                                        (pushnew *finalization-error-token*
 580                                                 *finalization-errors*
 581                                                 :test #'equal)
 582                                        :decline)))
 583                  (call-next-method)))
 584            (when *finalization-errors* (finalization-failed))
 585            (setf (slot-value class 'state) :finalized)
 586            t)))
 587
 588       ;; If the class is broken, we're not going to be able to fix it now.
 589       (:broken
 590        nil)
 591
 592       ;; If we already finalized it, there's no point doing it again.
 593       (:finalized
 594        t))))
 595
 596 (defmethod finalize-sod-class ((class sod-class))
 597
 598   ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
 599   ;; clone of the CPL and chain establishment code.  If the interface changes
 600   ;; then `bootstrap-classes' will need to be changed too.
 601
 602   ;; Finalize all of the superclasses.  There's some special pleading here to
 603   ;; make bootstrapping work: we don't try to finalize the metaclass if we're
 604   ;; a root class (no direct superclasses -- because in that case the
 605   ;; metaclass will have to be a subclass of us!), or if it's equal to us.
 606   ;; This is enough to tie the knot at the top of the class graph.  If we
 607   ;; can't manage this then we're doomed.
 608   (flet ((try-finalizing (what other-class)
 609            (unless (finalize-sod-class other-class)
 610              (cerror* "Class `~A' has broken ~A `~A'" class what other-class)
 611              (info-with-location other-class
 612                                  "Class `~A' defined here" other-class)
 613              (finalization-failed))))
 614     (let ((supers (sod-class-direct-superclasses class))
 615           (meta (sod-class-metaclass class)))
 616       (dolist (super supers)
 617         (try-finalizing "direct superclass" super))
 618       (unless (or (null supers) (eq class meta))
 619         (try-finalizing "metaclass" meta))))
 620
 621   ;; Stash the class's type.
 622   (setf (slot-value class '%type)
 623         (make-class-type (sod-class-name class)))
 624
 625   ;; Clobber the lists of items if they've not been set.
 626   (dolist (slot '(slots instance-initializers class-initializers
 627                   messages methods))
 628     (unless (slot-boundp class slot)
 629       (setf (slot-value class slot) nil)))
 630
 631   ;; If the CPL hasn't been done yet, compute it.  If we can't manage this
 632   ;; then there's no hope at all.
 633   (unless (slot-boundp class 'class-precedence-list)
 634     (restart-case
 635         (setf (slot-value class 'class-precedence-list) (compute-cpl class))
 636       (continue () :report "Continue"
 637         (finalization-failed))))
 638
 639   ;; Check that the class is fairly sane.
 640   (check-sod-class class)
 641
 642   ;; Determine the class's layout.
 643   (setf (values (slot-value class 'chain-head)
 644                 (slot-value class 'chain)
 645                 (slot-value class 'chains))
 646         (compute-chains class)))
 647
 648 ;;;----- That's all, folks --------------------------------------------------