X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/32bb097f2613b22e14feb1a9820eb21289856eb3..fddbedf7b1b4b19add30eeb62281748cc77e6955:/src/class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 32bc29b..895b3c9 100644
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -50,19 +50,65 @@
 
 ;;; Utilities.
 
+(export 'report-class-list-merge-error)
+(defun report-class-list-merge-error (class lists error)
+  "Report a failure to merge superclasseses.
+
+   Here, CLASS is the class whose class precedence list we're trying to
+   compute; the LISTS are the individual superclass orderings being merged;
+   and ERROR is an `inconsistent-merge-error' describing the problem that was
+   encountered.
+
+   Each of the LISTS is assumed to begin with the class from which the
+   corresponding constraint originates; see `merge-class-lists'."
+
+  (let* ((state (make-inheritance-path-reporter-state class))
+	 (candidates (merge-error-candidates error))
+	 (focus (remove-duplicates
+		 (remove nil
+			 (mapcar (lambda (list)
+				   (cons (car list)
+					 (remove-if-not
+					  (lambda (item)
+					    (member item candidates))
+					  list)))
+				 lists)
+			 :key #'cddr)
+		 :test #'equal :key #'cdr)))
+
+    (cerror*-with-location class "Ill-formed superclass graph: ~
+				  can't construct class precedence list ~
+				  for `~A'"
+			   class)
+    (dolist (offenders focus)
+      (let ((super (car offenders)))
+	(info-with-location super
+			    "~{Class `~A' orders `~A' before ~
+			       ~#[<BUG>~;`~A'~;`~A' and `~A'~:;~
+				  ~@{`~A', ~#[~;and `~A'~]~}~]~}"
+			    offenders)
+	(report-inheritance-path state super)))))
+
 (export 'merge-class-lists)
-(defun merge-class-lists (lists pick)
-  "Merge the LISTS of classes, using PICK to break ties.
+(defun merge-class-lists (class lists pick)
+  "Merge the LISTS of superclasses of CLASS, using PICK to break ties.
 
    This is a convenience wrapper around the main `merge-lists' function.
    Given that class linearizations (almost?) always specify a custom
-   tiebreaker function, this isn't a keyword argument.  Also, this wrapper
-   provides a standard presentation function so that any errors are presented
-   properly."
-  (merge-lists lists
-	       :pick pick
-	       :present (lambda (class)
-			  (format nil "`~A'" (sod-class-name class)))))
+   tiebreaker function, this isn't a keyword argument.
+
+   If a merge error occurs, this function translates it into a rather more
+   useful form, and tries to provide helpful notes.
+
+   For error reporting purposes, it's assumed that each of the LISTS begins
+   with the class from which the corresponding constraint originates.  This
+   initial class does double-duty: it is also considered to be part of the
+   list for the purpose of the merge."
+
+  (handler-case (merge-lists lists :pick pick)
+    (inconsistent-merge-error (error)
+      (report-class-list-merge-error class lists error)
+      (continue error))))
 
 ;;; Tiebreaker functions.
 
@@ -77,14 +123,11 @@
    direct subclass then that subclass's direct superclasses list must order
    them relative to each other."
 
-  (let (winner)
-    (dolist (class so-far)
-      (dolist (candidate candidates)
-	(when (member candidate (sod-class-direct-superclasses class))
-	  (setf winner candidate))))
-    (unless winner
-      (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
-    winner))
+  (dolist (class (reverse so-far))
+    (dolist (candidate candidates)
+      (when (member candidate (sod-class-direct-superclasses class))
+	(return-from clos-tiebreaker candidate))))
+  (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
 
 (defun c3-tiebreaker (candidates cpls)
   "The C3 linearization tiebreaker function.
@@ -133,11 +176,11 @@
 	       (remove-duplicates (cons class
 					(mappend #'superclasses
 						 direct-supers))))))
-    (merge-class-lists
-     (mapcar (lambda (class)
-	       (cons class (sod-class-direct-superclasses class)))
-	     (superclasses class))
-     #'clos-tiebreaker)))
+    (merge-class-lists class
+		       (mapcar (lambda (c)
+				 (cons c (sod-class-direct-superclasses c)))
+			       (superclasses class))
+		       #'clos-tiebreaker)))
 
 (export 'dylan-cpl)
 (defun dylan-cpl (class)
@@ -158,11 +201,11 @@
    assuming that the superclass CPLs are already monotonic.  If they aren't,
    you're going to lose anyway."
 
-  (let ((direct-supers (sod-class-direct-superclasses class)))
-    (merge-class-lists
-     (cons (cons class direct-supers)
-	   (mapcar #'sod-class-precedence-list direct-supers))
-     #'clos-tiebreaker)))
+  (let* ((direct-supers (sod-class-direct-superclasses class))
+	 (cpls (mapcar #'sod-class-precedence-list direct-supers)))
+    (merge-class-lists class
+		       (cons (cons class direct-supers) cpls)
+		       #'clos-tiebreaker)))
 
 (export 'c3-cpl)
 (defun c3-cpl (class)
@@ -179,7 +222,8 @@
 
   (let* ((direct-supers (sod-class-direct-superclasses class))
 	 (cpls (mapcar #'sod-class-precedence-list direct-supers)))
-    (merge-class-lists (cons (cons class direct-supers) cpls)
+    (merge-class-lists class
+		       (cons (cons class direct-supers) cpls)
 		       (lambda (candidates so-far)
 			 (declare (ignore so-far))
 			 (c3-tiebreaker candidates cpls)))))
@@ -242,7 +286,8 @@
 
   (let ((dfs (flavors-cpl class)))
     (cons class
-	  (merge-class-lists (mapcar #'sod-class-precedence-list
+	  (merge-class-lists class
+			     (mapcar #'sod-class-precedence-list
 				     (sod-class-direct-superclasses class))
 			     (lambda (candidates so-far)
 			       (declare (ignore so-far))
@@ -253,10 +298,7 @@
 ;;; Default function.
 
 (defmethod compute-cpl ((class sod-class))
-  (handler-case (c3-cpl class)
-    (inconsistent-merge-error ()
-      (error "Failed to compute class precedence list for `~A'"
-	     (sod-class-name class)))))
+  (c3-cpl class))
 
 ;;;--------------------------------------------------------------------------
 ;;; Chains.
@@ -269,6 +311,7 @@
 		       class))
 	     (chain (cons class (and chain-link
 				     (sod-class-chain chain-link))))
+	     (state (make-inheritance-path-reporter-state class))
 	     (table (make-hash-table)))
 
 	;; Check the chains.  We work through each superclass, maintaining a
@@ -277,13 +320,15 @@
 	;; we've found an error.  By the end of all of this, the classes
 	;; which don't have an entry are the chain tails.
 	(dolist (super class-precedence-list)
-	  (let ((link (sod-class-chain-link super)))
-	    (when link
-	      (when (gethash link table)
-		(error "Conflicting chains in class ~A: ~
-			(~A and ~A both link to ~A)"
-		       class super (gethash link table) link))
-	      (setf (gethash link table) super))))
+	  (let* ((link (sod-class-chain-link super))
+		 (found (and link (gethash link table))))
+	    (cond ((not found) (setf (gethash link table) super))
+		  (t
+		   (cerror* "Conflicting chains in class `~A': ~
+			     (`~A' and `~A' both link to `~A')"
+			    class super found link)
+		   (report-inheritance-path state super)
+		   (report-inheritance-path state found)))))
 
 	;; Done.
 	(values head chain
@@ -294,129 +339,207 @@
 					 (cdr class-precedence-list)))))))))
 
 ;;;--------------------------------------------------------------------------
-;;; Metaclasses.
-
-(defun maximum (items order what)
-  "Return a maximum item according to the non-strict partial ORDER."
-  (reduce (lambda (best this)
-	    (cond ((funcall order best this) best)
-		  ((funcall order this best) this)
-		  (t (error "Unable to choose best ~A" what))))
-	  items))
-
-(defmethod guess-metaclass ((class sod-class))
-  "Default metaclass-guessing function for classes.
-
-   Return the most specific metaclass of any of the CLASS's direct
-   superclasses."
-
-  ;; During bootstrapping, our superclasses might not have their own
-  ;; metaclasses resolved yet.  If we find this, then throw `bootstrapping'
-  ;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
-  ;; across the bows of anyone else who calls us).
-  (maximum (mapcar (lambda (super)
-		     (if (slot-boundp super 'metaclass)
-			 (slot-value super 'metaclass)
-			 (throw 'bootstrapping nil)))
-		   (sod-class-direct-superclasses class))
-	   #'sod-subclass-p
-	   (format nil "metaclass for `~A'" class)))
-
-;;;--------------------------------------------------------------------------
 ;;; Sanity checking.
 
+(defmethod check-class-initializer ((slot effective-slot) (class sod-class))
+  (finalization-error (:missing-class-initializer)
+    (unless (find-class-initializer slot class)
+      (let ((dslot (effective-slot-direct-slot slot)))
+	(cerror* "Missing initializer for class slot `~A', ~
+		  defined by meta-superclass `~A' of `~A'"
+		 dslot (sod-slot-class dslot) class)))))
+
+(defmethod check-class-initializer
+    ((slot sod-class-effective-slot) (class sod-class))
+  ;; The programmer shouldn't set an explicit initializer here.
+  (finalization-error (:invalid-class-initializer)
+    (let ((init (find-class-initializer slot class))
+	  (dslot (effective-slot-direct-slot slot)))
+      (when init
+	(cerror* "Initializers not permitted for class slot `~A', ~
+		  defined by meta-superclass `~A' of `~A'"
+		 dslot (sod-slot-class dslot) class)
+	(info-with-location init "Offending initializer defined here")))))
+
 (defmethod check-sod-class ((class sod-class))
-  (with-default-error-location (class)
 
-    ;; Check the names of things are valid.
-    (with-slots (name nickname messages) class
-      (unless (valid-name-p name)
-	(error "Invalid class name `~A'" class))
-      (unless (valid-name-p nickname)
-	(error "Invalid class nickname `~A' on class `~A'" nickname class))
-      (dolist (message messages)
-	(unless (valid-name-p (sod-message-name message))
-	  (error "Invalid message name `~A' on class `~A'"
-		 (sod-message-name message) class))))
-
-    ;; Check that the slots and messages have distinct names.
-    (with-slots (slots messages class-precedence-list) class
-      (flet ((check-list (list what namefunc)
-	       (let ((table (make-hash-table :test #'equal)))
-		 (dolist (item list)
-		   (let ((name (funcall namefunc item)))
-		     (if (gethash name table)
-			 (error "Duplicate ~A name `~A' on class `~A'"
-				what name class)
-			 (setf (gethash name table) item)))))))
-	(check-list slots "slot" #'sod-slot-name)
-	(check-list messages "message" #'sod-message-name)
-	(check-list class-precedence-list "nickname" #'sod-class-name)))
-
-    ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
-    ;; eliminates hairy things like a class being its own link.)
-    (with-slots (class-precedence-list chain-link) class
-      (unless (or (not chain-link)
-		  (member chain-link (cdr class-precedence-list)))
-	(error "In `~A~, chain-to class `~A' is not a proper superclass"
-	       class chain-link)))
-
-    ;; Check that the initargs declare compatible types.  Duplicate entries,
-    ;; even within a class, are harmless, but at most one initarg in any
-    ;; class should declare a default value.
-    (with-slots (class-precedence-list) class
-      (let ((seen (make-hash-table :test #'equal)))
-	(dolist (super class-precedence-list)
-	  (with-slots (initargs) super
-	    (dolist (initarg (reverse initargs))
-	      (let* ((initarg-name (sod-initarg-name initarg))
-		     (initarg-type (sod-initarg-type initarg))
-		     (initarg-default (sod-initarg-default initarg))
-		     (found (gethash initarg-name seen))
-		     (found-type (and found (sod-initarg-type found)))
-		     (found-default (and found (sod-initarg-default found)))
-		     (found-class (and found (sod-initarg-class found)))
-		     (found-location (and found (file-location found))))
-		(with-default-error-location (initarg)
-		  (cond ((not found)
-			 (setf (gethash initarg-name seen) initarg))
-			((not (c-type-equal-p initarg-type found-type))
-			 (cerror* "Inititalization argument `~A' defined ~
-				   with incompatible types: ~
-				   ~A in class ~A, and ~
-				   ~A in class ~A (at ~A)"
-				initarg-name initarg-type super
-				found-type found-class found-location))
-			((and initarg-default found-default
-			      (eql super found-class))
-			 (cerror* "Initialization argument `~A' redefined ~
-				   with default value ~
-				   (previous definition at ~A)"
-				  initarg-name found-location))
-			(initarg-default
-			 (setf (gethash initarg-name seen) initarg))))))))))
-
-    ;; Check for circularity in the superclass graph.  Since the superclasses
-    ;; should already be acyclic, it suffices to check that our class is not
-    ;; a superclass of any of its own direct superclasses.
-    (let ((circle (find-if (lambda (super)
-			     (sod-subclass-p super class))
-			   (sod-class-direct-superclasses class))))
-      (when circle
-	(error "Circularity: ~A is already a superclass of ~A"
-	       class circle)))
-
-    ;; Check that the class has a unique root superclass.
-    (find-root-superclass class)
-
-    ;; Check that the metaclass is a subclass of each direct superclass's
-    ;; metaclass.
-    (with-slots (metaclass direct-superclasses) class
-      (dolist (super direct-superclasses)
-	(unless (sod-subclass-p metaclass (sod-class-metaclass super))
-	  (error "Incompatible metaclass for `~A': ~
-		  `~A' isn't a subclass of `~A' (of `~A')"
-		 class metaclass (sod-class-metaclass super) super))))))
+  ;; Check the names of things are valid.
+  (flet ((check-list (list what namefunc)
+	   (dolist (item list)
+	     (let ((name (funcall namefunc item)))
+	       (unless (valid-name-p name)
+		 (cerror*-with-location item
+					"Invalid ~A name `~A' in class `~A'"
+					what name class))))))
+    (unless (valid-name-p (sod-class-name class))
+      (cerror* "Invalid class name `~A'" class))
+    (unless (valid-name-p (sod-class-nickname class))
+      (cerror* "Invalid class nickname `~A' for class `~A'"
+	       (sod-class-nickname class) class))
+    (check-list (sod-class-messages class) "message" #'sod-message-name)
+    (check-list (sod-class-slots class) "slot" #'sod-slot-name))
+
+  ;; Check that the class doesn't define conflicting things.
+  (labels ((simple-previous (previous)
+	     (info-with-location previous "Previous definition was here"))
+	   (simple-complain (what namefunc)
+	     (lambda (item previous)
+	       (cerror*-with-location item
+				      "Duplicate ~A `~A' in class `~A'"
+				      what (funcall namefunc item) class)
+	       (simple-previous previous))))
+
+    ;; Make sure direct slots have distinct names.
+    (find-duplicates (simple-complain "slot name" #'sod-slot-name)
+		     (sod-class-slots class)
+		     :key #'sod-slot-name
+		     :test #'equal)
+
+    ;; Make sure there's at most one initializer for each slot.
+    (flet ((check-initializer-list (list kind)
+	     (find-duplicates (lambda (initializer previous)
+				(let ((slot
+				       (sod-initializer-slot initializer)))
+				  (cerror*-with-location initializer
+							 "Duplicate ~
+							  initializer ~
+							  for ~A slot `~A' ~
+							  in class `~A'"
+							 kind slot class)
+				  (simple-previous previous)))
+			      list
+			      :key #'sod-initializer-slot)))
+      (check-initializer-list (sod-class-instance-initializers class)
+			      "instance")
+      (check-initializer-list (sod-class-class-initializers class)
+			      "class"))
+
+    ;; Make sure messages have distinct names.
+    (find-duplicates (simple-complain "message name" #'sod-message-name)
+		     (sod-class-messages class)
+		     :key #'sod-message-name
+		     :test #'equal)
+
+    ;; Make sure methods are sufficiently distinct.
+    (find-duplicates (lambda (method previous)
+		       (cerror*-with-location method
+					      "Duplicate ~A direct method ~
+					       for message `~A' ~
+					       in classs `~A'"
+					      (sod-method-description method)
+					      (sod-method-message method)
+					      class)
+		       (simple-previous previous))
+		     (sod-class-methods class)
+		     :key #'sod-method-function-name
+		     :test #'equal)
+
+    ;; Make sure superclasses have distinct nicknames.
+    (let ((state (make-inheritance-path-reporter-state class)))
+      (find-duplicates (lambda (super previous)
+			 (cerror*-with-location class
+						"Duplicate nickname `~A' ~
+						 in superclasses of `~A': ~
+						 used by `~A' and `~A'"
+						(sod-class-nickname super)
+						class super previous)
+			 (report-inheritance-path state super)
+			 (report-inheritance-path state previous))
+		       (sod-class-precedence-list class)
+		       :key #'sod-class-nickname :test #'equal)))
+
+  ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
+  ;; eliminates hairy things like a class being its own link.)
+  (let ((link (sod-class-chain-link class)))
+    (unless (or (not link)
+		(member link (cdr (sod-class-precedence-list class))))
+      (cerror* "In `~A', chain-to class `~A' is not a proper superclass"
+	       class link)))
+
+  ;; Check that the initargs declare compatible types.  Duplicate entries,
+  ;; even within a class, are harmless, but at most one initarg in any
+  ;; class should declare a default value.
+  (let ((seen (make-hash-table :test #'equal))
+	(state (make-inheritance-path-reporter-state class)))
+    (dolist (super (sod-class-precedence-list class))
+      (dolist (initarg (reverse (sod-class-initargs super)))
+	(let* ((initarg-name (sod-initarg-name initarg))
+	       (initarg-type (sod-initarg-type initarg))
+	       (initarg-default (sod-initarg-default initarg))
+	       (found (gethash initarg-name seen))
+	       (found-type (and found (sod-initarg-type found)))
+	       (found-default (and found (sod-initarg-default found)))
+	       (found-class (and found (sod-initarg-class found)))
+	       (found-location (and found (file-location found))))
+	  (with-default-error-location (initarg)
+	    (cond ((not found)
+		   (setf (gethash initarg-name seen) initarg))
+		  ((not (c-type-equal-p initarg-type found-type))
+		   (cerror* "Inititalization argument `~A' defined ~
+			     with incompatible types: ~
+			     ~A in class `~A', but ~A in class `~A'"
+			    initarg-name initarg-type super
+			    found-type found-class found-location)
+		   (report-inheritance-path state super))
+		  ((and initarg-default found-default
+			(eql super found-class))
+		   (cerror* "Initialization argument `~A' redefined ~
+			     with default value"
+			    initarg-name)
+		   (info-with-location found-location
+				       "Previous definition is here"))
+		  (initarg-default
+		   (setf (gethash initarg-name seen) initarg))))))))
+
+  ;; Check for circularity in the superclass graph.  Since the superclasses
+  ;; should already be acyclic, it suffices to check that our class is not
+  ;; a superclass of any of its own direct superclasses.
+  (let ((circle (find-if (lambda (super)
+			   (sod-subclass-p super class))
+			 (sod-class-direct-superclasses class))))
+    (when circle
+      (cerror* "`~A' is already a superclass of `~A'" class circle)
+      (report-inheritance-path (make-inheritance-path-reporter-state class)
+			       circle)))
+
+  ;; Check that the class has a unique root superclass.
+  (find-root-superclass class)
+
+  ;; Check that the metaclass is a subclass of each direct superclass's
+  ;; metaclass.
+  (finalization-error (:bad-metaclass)
+    (let ((meta (sod-class-metaclass class)))
+      (dolist (super (sod-class-direct-superclasses class))
+	(let ((supermeta (sod-class-metaclass super)))
+	  (unless (sod-subclass-p meta supermeta)
+	    (cerror* "Metaclass `~A' of `~A' isn't a subclass of `~A'"
+		     meta class supermeta)
+	    (info-with-location super
+				"Direct superclass `~A' defined here ~
+				 has metaclass `~A'"
+				super supermeta))))))
+
+  ;; Check that all of the messages we can be sent have coherent collections
+  ;; of applicable methods.  This can go wrong, for example, if we inherit
+  ;; methods with differently typed keyword arguments.
+  (finalization-error (:mismatched-applicable-methods)
+    (dolist (super (sod-class-precedence-list class))
+      (dolist (message (sod-class-messages super))
+	(let ((methods (sod-message-applicable-methods message class)))
+	  (sod-message-check-methods message class methods)))))
+
+  ;; Check that an initializer is available for every slot in the class's
+  ;; metaclass.  Skip this and trust the caller if the metaclass isn't
+  ;; finalized yet: in that case, we must be bootstrapping, and we must hope
+  ;; that the caller knows what they're doing.
+  (let* ((meta (sod-class-metaclass class))
+	 (ilayout (and (eq (sod-class-state meta) :finalized)
+		       (sod-class-ilayout meta))))
+    (dolist (ichain (and ilayout (ilayout-ichains ilayout)))
+      (dolist (item (cdr (ichain-body ichain)))
+	(when (typep item 'islots)
+	  (dolist (slot (islots-slots item))
+	    (check-class-initializer slot class)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Finalization.
@@ -438,10 +561,29 @@
        ;; If this fails, leave the class marked as a loss.
        (setf (slot-value class 'state) :broken)
 
-       ;; Invoke the finalization method proper.
-       (call-next-method)
-       (setf (slot-value class 'state) :finalized)
-       t)
+       ;; Invoke the finalization method proper.  If it signals any
+       ;; continuable errors, take note of them so that we can report failure
+       ;; properly.
+       ;;
+       ;; Catch: we get called recursively to clean up superclasses and
+       ;; metaclasses, but there should only be one such handler, so don't
+       ;; add another.  (In turn, this means that other methods mustn't
+       ;; actually trap their significant errors.)
+       (let ((have-handler-p (boundp '*finalization-errors*))
+	     (*finalization-errors* nil)
+	     (*finalization-error-token* nil))
+	 (catch '%finalization-failed
+	   (if have-handler-p (call-next-method)
+	       (handler-bind ((error (lambda (cond)
+				       (declare (ignore cond))
+				       (pushnew *finalization-error-token*
+						*finalization-errors*
+						:test #'equal)
+				       :decline)))
+		 (call-next-method)))
+	   (when *finalization-errors* (finalization-failed))
+	   (setf (slot-value class 'state) :finalized)
+	   t)))
 
       ;; If the class is broken, we're not going to be able to fix it now.
       (:broken
@@ -457,22 +599,24 @@
   ;; clone of the CPL and chain establishment code.  If the interface changes
   ;; then `bootstrap-classes' will need to be changed too.
 
-  ;; Set up the metaclass if it's not been set already.  This is delayed
-  ;; to give bootstrapping a chance to set up metaclass and superclass
-  ;; circularities.
-  (default-slot (class 'metaclass) (guess-metaclass class))
-
   ;; Finalize all of the superclasses.  There's some special pleading here to
   ;; make bootstrapping work: we don't try to finalize the metaclass if we're
   ;; a root class (no direct superclasses -- because in that case the
   ;; metaclass will have to be a subclass of us!), or if it's equal to us.
-  ;; This is enough to tie the knot at the top of the class graph.
-  (with-slots (name direct-superclasses metaclass) class
-    (dolist (super direct-superclasses)
-      (finalize-sod-class super))
-    (unless (or (null direct-superclasses)
-		(eq class metaclass))
-      (finalize-sod-class metaclass)))
+  ;; This is enough to tie the knot at the top of the class graph.  If we
+  ;; can't manage this then we're doomed.
+  (flet ((try-finalizing (what other-class)
+	   (unless (finalize-sod-class other-class)
+	     (cerror* "Class `~A' has broken ~A `~A'" class what other-class)
+	     (info-with-location other-class
+				 "Class `~A' defined here" other-class)
+	     (finalization-failed))))
+    (let ((supers (sod-class-direct-superclasses class))
+	  (meta (sod-class-metaclass class)))
+      (dolist (super supers)
+	(try-finalizing "direct superclass" super))
+      (unless (or (null supers) (eq class meta))
+	(try-finalizing "metaclass" meta))))
 
   ;; Stash the class's type.
   (setf (slot-value class '%type)
@@ -484,10 +628,13 @@
     (unless (slot-boundp class slot)
       (setf (slot-value class slot) nil)))
 
-  ;; If the CPL hasn't been done yet, compute it.
-  (with-slots (class-precedence-list) class
-    (unless (slot-boundp class 'class-precedence-list)
-      (setf class-precedence-list (compute-cpl class))))
+  ;; If the CPL hasn't been done yet, compute it.  If we can't manage this
+  ;; then there's no hope at all.
+  (unless (slot-boundp class 'class-precedence-list)
+    (restart-case
+	(setf (slot-value class 'class-precedence-list) (compute-cpl class))
+      (continue () :report "Continue"
+	(finalization-failed))))
 
   ;; Check that the class is fairly sane.
   (check-sod-class class)