Reduce consing during SUBTYPEP on classes.

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

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 9054a5a..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)
@@ -68,9 +78,12 @@
 \f
 ;;;; STANDARD-INSTANCE-ACCESS
 
-(declaim (inline standard-instance-access (setf standard-instance-access)
+(declaim (inline standard-instance-access
+                 (setf standard-instance-access)
+                 (cas stadard-instance-access)
                  funcallable-standard-instance-access
-                 (setf funcallable-standard-instance-access)))
+                 (setf funcallable-standard-instance-access)
+                 (cas funcallable-standard-instance-access)))
 
 (defun standard-instance-access (instance location)
   (clos-slots-ref (std-instance-slots instance) location))
@@ -78,11 +91,19 @@
 (defun (setf standard-instance-access) (new-value instance location)
   (setf (clos-slots-ref (std-instance-slots instance) location) new-value))
 
+(defun (cas standard-instance-access) (old-value new-value instance location)
+  ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely?
+  (cas (svref (std-instance-slots instance) location) old-value new-value))
+
 (defun funcallable-standard-instance-access (instance location)
   (clos-slots-ref (fsc-instance-slots instance) location))
 
 (defun (setf funcallable-standard-instance-access) (new-value instance location)
   (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value))
+
+(defun (cas funcallable-standard-instance-access) (old-value new-value instance location)
+  ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely?
+  (cas (svref (fsc-instance-slots instance) location) old-value new-value))
 \f
 ;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
 
@@ -165,6 +186,34 @@
       `(accessor-set-slot-value ,object ,slot-name ,new-value)
       form))
 
+(defun (cas slot-value) (old-value new-value object slot-name)
+  (let* ((wrapper (valid-wrapper-of object))
+         (cell (or (find-slot-cell wrapper slot-name)
+                   (return-from slot-value
+                     (values (slot-missing (wrapper-class* wrapper) object slot-name
+                                           'cas (list old-value new-value))))))
+         (location (car cell))
+         (info (cdr cell))
+         (typecheck (slot-info-typecheck info)))
+    (when typecheck
+      (funcall typecheck new-value))
+    (let ((old (cond ((fixnump location)
+                      (if (std-instance-p object)
+                          (cas (standard-instance-access object location) old-value new-value)
+                          (cas (funcallable-standard-instance-access object location)
+                               old-value new-value)))
+                     ((consp location)
+                      (cas (cdr location) old-value new-value))
+                     ((not location)
+                      ;; FIXME: (CAS SLOT-VALUE-USING-CLASS)...
+                      (error "Cannot compare-and-swap slot ~S on: ~S" slot-name object))
+                     (t
+                      (bug "Bogus slot-cell in (CAS SLOT-VALUE): ~S" cell)))))
+      (if (and (eq +slot-unbound+ old)
+               (neq old old-value))
+          (slot-unbound (wrapper-class* wrapper) object slot-name)
+          old))))
+
 (defun slot-boundp (object slot-name)
   (let* ((wrapper (valid-wrapper-of object))
          (cell (or (find-slot-cell wrapper slot-name)
@@ -439,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)
@@ -453,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))