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