gencgc: More precise conservatism for pointers to boxed pages.

[sbcl.git] / src / pcl / slots.lisp

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 26a8355..2ae32b0 100644 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -28,9 +28,19 @@
 (define-condition unbound-slot (cell-error)
   ((instance :reader unbound-slot-instance :initarg :instance))
   (:report (lambda (condition stream)
-             (format stream "The slot ~S is unbound in the object ~S."
-                     (cell-error-name condition)
-                     (unbound-slot-instance condition)))))
+             (handler-case
+                 (format stream "~@<The slot ~/sb-ext:print-symbol-with-prefix/ ~
+                         is unbound in the object ~A.~@:>"
+                         (cell-error-name condition)
+                         (unbound-slot-instance condition))
+               (serious-condition ()
+                 ;; In case of an error try again avoiding custom PRINT-OBJECT's.
+                 (format stream "~&Error during printing.~%~@<The slot ~
+                         ~/sb-ext:print-symbol-with-prefix/ ~
+                         is unbound in an instance of ~
+                         ~/sb-ext:print-symbol-with-prefix/.~@:>"
+                         (cell-error-name condition)
+                         (type-of (unbound-slot-instance condition))))))))
 
 (defmethod wrapper-fetcher ((class standard-class))
   'std-instance-wrapper)
@@ -478,7 +488,7 @@
 \f
 ;;; FIXME: AMOP says that allocate-instance imples finalize-inheritance
 ;;; if the class is not yet finalized, but we don't seem to be taking
-;;; care of this for non-standard-classes.x
+;;; care of this for non-standard-classes.
 (defmethod allocate-instance ((class standard-class) &rest initargs)
   (declare (ignore initargs))
   (unless (class-finalized-p class)
@@ -492,11 +502,9 @@
         (funcall constructor)
         (error "Don't know how to allocate ~S" class))))
 
-;;; FIXME: It would be nicer to have allocate-instance return
-;;; uninitialized objects for conditions as well.
 (defmethod allocate-instance ((class condition-class) &rest initargs)
   (declare (ignore initargs))
-  (make-condition (class-name class)))
+  (allocate-condition (class-name class)))
 
 (defmethod allocate-instance ((class built-in-class) &rest initargs)
   (declare (ignore initargs))