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 '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 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 ;;; Metaclasses.
 343
 344 (defmethod guess-metaclass ((class sod-class))
 345   "Default metaclass-guessing function for classes.
 346
 347    Return the most specific metaclass of any of the CLASS's direct
 348    superclasses."
 349
 350   ;; During bootstrapping, our superclasses might not have their own
 351   ;; metaclasses resolved yet.  If we find this, then throw `bootstrapping'
 352   ;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
 353   ;; across the bows of anyone else who calls us).
 354   (finalization-error (:bad-metaclass)
 355     (select-minimal-class-property (sod-class-direct-superclasses class)
 356                                    (lambda (super)
 357                                      (if (slot-boundp super 'metaclass)
 358                                          (slot-value super 'metaclass)
 359                                          (throw 'bootstrapping nil)))
 360                                    #'sod-subclass-p class "metaclass")))
 361
 362 ;;;--------------------------------------------------------------------------
 363 ;;; Sanity checking.
 364
 365 (defmethod check-sod-class ((class sod-class))
 366   (with-default-error-location (class)
 367
 368     ;; Check the names of things are valid.
 369     (flet ((check-list (list what namefunc)
 370              (dolist (item list)
 371                (let ((name (funcall namefunc item)))
 372                  (unless (valid-name-p name)
 373                    (cerror*-with-location item
 374                                           "Invalid ~A name `~A' ~
 375                                            in class `~A'"
 376                                           what name class))))))
 377       (unless (valid-name-p (sod-class-name class))
 378         (cerror* "Invalid class name `~A'" class))
 379       (unless (valid-name-p (sod-class-nickname class))
 380         (cerror* "Invalid class nickname `~A' for class `~A'"
 381                  (sod-class-nickname class) class))
 382       (check-list (sod-class-messages class) "message" #'sod-message-name)
 383       (check-list (sod-class-slots class) "slot" #'sod-slot-name))
 384
 385     ;; Check that the class doesn't define conflicting things.
 386     (labels ((check-list (list keyfunc complain)
 387                (let ((seen (make-hash-table :test #'equal)))
 388                  (dolist (item list)
 389                    (let* ((key (funcall keyfunc item))
 390                           (found (gethash key seen)))
 391                      (if found (funcall complain item found)
 392                          (setf (gethash key seen) item))))))
 393              (simple-previous (previous)
 394                (info-with-location previous "Previous definition was here"))
 395              (simple-complain (what namefunc)
 396                (lambda (item previous)
 397                  (cerror*-with-location item
 398                                         "Duplicate ~A `~A' in class `~A'"
 399                                         what (funcall namefunc item) class)
 400                  (simple-previous previous))))
 401
 402         ;; Make sure direct slots have distinct names.
 403         (check-list (sod-class-slots class) #'sod-slot-name
 404                     (simple-complain "slot name" #'sod-slot-name))
 405
 406         ;; Make sure there's at most one initializer for each slot.
 407         (flet ((check-initializer-list (list kind)
 408                  (check-list list #'sod-initializer-slot
 409                              (lambda (initializer previous)
 410                                (let ((slot
 411                                       (sod-initializer-slot initializer)))
 412                                  (cerror*-with-location initializer
 413                                                         "Duplicate ~
 414                                                          initializer for ~
 415                                                          ~A slot `~A' ~
 416                                                          in class `~A'"
 417                                                         kind slot class)
 418                                  (simple-previous previous))))))
 419           (check-initializer-list (sod-class-instance-initializers class)
 420                                   "instance")
 421           (check-initializer-list (sod-class-class-initializers class)
 422                                   "class"))
 423
 424         ;; Make sure messages have distinct names.
 425         (check-list (sod-class-messages class) #'sod-message-name
 426                     (simple-complain "message name" #'sod-message-name))
 427
 428         ;; Make sure methods are sufficiently distinct.
 429         (check-list (sod-class-methods class) #'sod-method-function-name
 430                     (lambda (method previous)
 431                       (cerror*-with-location method
 432                                              "Duplicate ~A direct method ~
 433                                               for message `~A' ~
 434                                               in classs `~A'"
 435                                              (sod-method-description method)
 436                                              (sod-method-message method)
 437                                              class)
 438                       (simple-previous previous)))
 439
 440         ;; Make sure superclasses have distinct nicknames.
 441         (let ((state (make-inheritance-path-reporter-state class)))
 442           (check-list (sod-class-precedence-list class) #'sod-class-nickname
 443                       (lambda (super previous)
 444                         (cerror*-with-location class
 445                                                "Duplicate nickname `~A' ~
 446                                                 in superclasses of `~A': ~
 447                                                 used by `~A' and `~A'"
 448                                                (sod-class-nickname super)
 449                                                class super previous)
 450                         (report-inheritance-path state super)
 451                         (report-inheritance-path state previous)))))
 452
 453     ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
 454     ;; eliminates hairy things like a class being its own link.)
 455     (let ((link (sod-class-chain-link class)))
 456       (unless (or (not link)
 457                   (member link (cdr (sod-class-precedence-list class))))
 458         (cerror* "In `~A~, chain-to class `~A' is not a proper superclass"
 459                  class link)))
 460
 461     ;; Check that the initargs declare compatible types.  Duplicate entries,
 462     ;; even within a class, are harmless, but at most one initarg in any
 463     ;; class should declare a default value.
 464     (let ((seen (make-hash-table :test #'equal))
 465           (state (make-inheritance-path-reporter-state class)))
 466       (dolist (super (sod-class-precedence-list class))
 467         (dolist (initarg (reverse (sod-class-initargs super)))
 468           (let* ((initarg-name (sod-initarg-name initarg))
 469                  (initarg-type (sod-initarg-type initarg))
 470                  (initarg-default (sod-initarg-default initarg))
 471                  (found (gethash initarg-name seen))
 472                  (found-type (and found (sod-initarg-type found)))
 473                  (found-default (and found (sod-initarg-default found)))
 474                  (found-class (and found (sod-initarg-class found)))
 475                  (found-location (and found (file-location found))))
 476             (with-default-error-location (initarg)
 477               (cond ((not found)
 478                      (setf (gethash initarg-name seen) initarg))
 479                     ((not (c-type-equal-p initarg-type found-type))
 480                      (cerror* "Inititalization argument `~A' defined ~
 481                                with incompatible types: ~
 482                                ~A in class `~A', but ~A in class `~A'"
 483                               initarg-name initarg-type super
 484                               found-type found-class found-location)
 485                      (report-inheritance-path state super))
 486                     ((and initarg-default found-default
 487                           (eql super found-class))
 488                      (cerror* "Initialization argument `~A' redefined ~
 489                                with default value"
 490                               initarg-name)
 491                      (info-with-location found-location
 492                                          "Previous definition is here"))
 493                     (initarg-default
 494                      (setf (gethash initarg-name seen) initarg))))))))
 495
 496     ;; Check for circularity in the superclass graph.  Since the superclasses
 497     ;; should already be acyclic, it suffices to check that our class is not
 498     ;; a superclass of any of its own direct superclasses.
 499     (let ((circle (find-if (lambda (super)
 500                              (sod-subclass-p super class))
 501                            (sod-class-direct-superclasses class))))
 502       (when circle
 503         (cerror* "`~A' is already a superclass of `~A'" class circle)
 504         (report-inheritance-path (make-inheritance-path-reporter-state class)
 505                                  circle)))
 506
 507     ;; Check that the class has a unique root superclass.
 508     (find-root-superclass class)
 509
 510     ;; Check that the metaclass is a subclass of each direct superclass's
 511     ;; metaclass.
 512     (finalization-error (:bad-metaclass)
 513       (let ((meta (sod-class-metaclass class)))
 514         (dolist (super (sod-class-direct-superclasses class))
 515           (let ((supermeta (sod-class-metaclass super)))
 516             (unless (sod-subclass-p meta supermeta)
 517               (cerror* "Metaclass `~A' of `~A' isn't a subclass of `~A'"
 518                        meta class supermeta)
 519               (info-with-location super
 520                                   "Direct superclass `~A' defined here ~
 521                                    has metaclass `~A'"
 522                                   super supermeta))))))))
 523
 524 ;;;--------------------------------------------------------------------------
 525 ;;; Finalization.
 526
 527 (defmethod finalize-sod-class :around ((class sod-class))
 528   "Common functionality for `finalize-sod-class'.
 529
 530      * If an attempt to finalize the CLASS has been made before, then we
 531        don't try again.  Similarly, attempts to finalize a class recursively
 532        will fail.
 533
 534      * A condition handler is established to keep track of whether any errors
 535        are signalled during finalization.  The CLASS is only marked as
 536        successfully finalized if no (unhandled) errors are encountered."
 537   (with-default-error-location (class)
 538     (ecase (sod-class-state class)
 539       ((nil)
 540
 541        ;; If this fails, leave the class marked as a loss.
 542        (setf (slot-value class 'state) :broken)
 543
 544        ;; Invoke the finalization method proper.  If it signals any
 545        ;; continuable errors, take note of them so that we can report failure
 546        ;; properly.
 547        ;;
 548        ;; Catch: we get called recursively to clean up superclasses and
 549        ;; metaclasses, but there should only be one such handler, so don't
 550        ;; add another.  (In turn, this means that other methods mustn't
 551        ;; actually trap their significant errors.)
 552        (let ((have-handler-p (boundp '*finalization-errors*))
 553              (*finalization-errors* nil)
 554              (*finalization-error-token* nil))
 555          (catch '%finalization-failed
 556            (if have-handler-p (call-next-method)
 557                (handler-bind ((error (lambda (cond)
 558                                        (declare (ignore cond))
 559                                        (pushnew *finalization-error-token*
 560                                                 *finalization-errors*
 561                                                 :test #'equal)
 562                                        :decline)))
 563                  (call-next-method)))
 564            (when *finalization-errors* (finalization-failed))
 565            (setf (slot-value class 'state) :finalized)
 566            t)))
 567
 568       ;; If the class is broken, we're not going to be able to fix it now.
 569       (:broken
 570        nil)
 571
 572       ;; If we already finalized it, there's no point doing it again.
 573       (:finalized
 574        t))))
 575
 576 (defmethod finalize-sod-class ((class sod-class))
 577
 578   ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
 579   ;; clone of the CPL and chain establishment code.  If the interface changes
 580   ;; then `bootstrap-classes' will need to be changed too.
 581
 582   ;; Set up the metaclass if it's not been set already.  This is delayed
 583   ;; to give bootstrapping a chance to set up metaclass and superclass
 584   ;; circularities.
 585   (default-slot (class 'metaclass) (guess-metaclass class))
 586
 587   ;; Finalize all of the superclasses.  There's some special pleading here to
 588   ;; make bootstrapping work: we don't try to finalize the metaclass if we're
 589   ;; a root class (no direct superclasses -- because in that case the
 590   ;; metaclass will have to be a subclass of us!), or if it's equal to us.
 591   ;; This is enough to tie the knot at the top of the class graph.  If we
 592   ;; can't manage this then we're doomed.
 593   (flet ((try-finalizing (what other-class)
 594            (unless (finalize-sod-class other-class)
 595              (cerror* "Class `~A' has broken ~A `~A'" class what other-class)
 596              (info-with-location other-class
 597                                  "Class `~A' defined here" other-class)
 598              (finalization-failed))))
 599     (let ((supers (sod-class-direct-superclasses class))
 600           (meta (sod-class-metaclass class)))
 601       (dolist (super supers)
 602         (try-finalizing "direct superclass" super))
 603       (unless (or (null supers) (eq class meta))
 604         (try-finalizing "metaclass" meta))))
 605
 606   ;; Stash the class's type.
 607   (setf (slot-value class '%type)
 608         (make-class-type (sod-class-name class)))
 609
 610   ;; Clobber the lists of items if they've not been set.
 611   (dolist (slot '(slots instance-initializers class-initializers
 612                   messages methods))
 613     (unless (slot-boundp class slot)
 614       (setf (slot-value class slot) nil)))
 615
 616   ;; If the CPL hasn't been done yet, compute it.  If we can't manage this
 617   ;; then there's no hope at all.
 618   (unless (slot-boundp class 'class-precedence-list)
 619     (restart-case
 620         (setf (slot-value class 'class-precedence-list) (compute-cpl class))
 621       (continue () :report "Continue"
 622         (finalization-failed))))
 623
 624   ;; Check that the class is fairly sane.
 625   (check-sod-class class)
 626
 627   ;; Determine the class's layout.
 628   (setf (values (slot-value class 'chain-head)
 629                 (slot-value class 'chain)
 630                 (slot-value class 'chains))
 631         (compute-chains class)))
 632
 633 ;;;----- That's all, folks --------------------------------------------------