0.8.0.2:

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

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 274d682..6bd1e8b 100644 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -130,29 +130,36 @@
     t))
 
 (defun get-optimized-std-accessor-method-function (class slotd name)
-  (if (structure-class-p class)
-      (ecase name
-       (reader (slot-definition-internal-reader-function slotd))
-       (writer (slot-definition-internal-writer-function slotd))
-       (boundp (make-structure-slot-boundp-function slotd)))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-                         ((funcallable-standard-class-p class) t)
-                         ((std-class-p class)
-                          ;; Shouldn't be using the optimized-std-accessors
-                          ;; in this case.
-                          #+nil (format t "* warning: ~S ~S~%   ~S~%"
-                                  name slotd class)
-                          nil)
-                         (t (error "~S is not a STANDARD-CLASS." class))))
-            (slot-name (slot-definition-name slotd))
-            (index (slot-definition-location slotd))
-            (function (ecase name
-                        (reader #'make-optimized-std-reader-method-function)
-                        (writer #'make-optimized-std-writer-method-function)
-                        (boundp #'make-optimized-std-boundp-method-function)))
-            (value (funcall function fsc-p slot-name index)))
-       (declare (type function function))
-       (values value index))))
+  (cond
+    ((structure-class-p class)
+     (ecase name
+       (reader (slot-definition-internal-reader-function slotd))
+       (writer (slot-definition-internal-writer-function slotd))
+       (boundp (make-structure-slot-boundp-function slotd))))
+    ((condition-class-p class)
+     (ecase name
+       (reader (slot-definition-reader-function slotd))
+       (writer (slot-definition-writer-function slotd))
+       (boundp (slot-definition-boundp-function slotd))))
+    (t
+     (let* ((fsc-p (cond ((standard-class-p class) nil)
+                        ((funcallable-standard-class-p class) t)
+                        ((std-class-p class)
+                         ;; Shouldn't be using the optimized-std-accessors
+                         ;; in this case.
+                         #+nil (format t "* warning: ~S ~S~%   ~S~%"
+                                       name slotd class)
+                         nil)
+                        (t (error "~S is not a STANDARD-CLASS." class))))
+           (slot-name (slot-definition-name slotd))
+           (index (slot-definition-location slotd))
+           (function (ecase name
+                       (reader #'make-optimized-std-reader-method-function)
+                       (writer #'make-optimized-std-writer-method-function)
+                       (boundp #'make-optimized-std-boundp-method-function)))
+           (value (funcall function fsc-p slot-name index)))
+       (declare (type function function))
+       (values value index)))))
 
 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
   (declare #.*optimize-speed*)
@@ -236,31 +243,52 @@
     (declare (ignore class object slotd))
     t))
 
-(defun get-optimized-std-slot-value-using-class-method-function (class
-                                                                slotd
-                                                                name)
-  (if (structure-class-p class)
-      (ecase name
-       (reader (make-optimized-structure-slot-value-using-class-method-function
-                (slot-definition-internal-reader-function slotd)))
-       (writer (make-optimized-structure-setf-slot-value-using-class-method-function
-                (slot-definition-internal-writer-function slotd)))
-       (boundp (make-optimized-structure-slot-boundp-using-class-method-function)))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-                         ((funcallable-standard-class-p class) t)
-                         (t (error "~S is not a standard-class" class))))
-            (slot-name (slot-definition-name slotd))
-            (index (slot-definition-location slotd))
-            (function
-             (ecase name
-               (reader
-                #'make-optimized-std-slot-value-using-class-method-function)
-               (writer
-                #'make-optimized-std-setf-slot-value-using-class-method-function)
-               (boundp
-                #'make-optimized-std-slot-boundp-using-class-method-function))))
-       (declare (type function function))
-       (values (funcall function fsc-p slot-name index) index))))
+(defun get-optimized-std-slot-value-using-class-method-function
+    (class slotd name)
+  (cond
+    ((structure-class-p class)
+     (ecase name
+       (reader (make-optimized-structure-slot-value-using-class-method-function
+               (slot-definition-internal-reader-function slotd)))
+       (writer (make-optimized-structure-setf-slot-value-using-class-method-function
+               (slot-definition-internal-writer-function slotd)))
+       (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
+    ((condition-class-p class)
+     (ecase name
+       (reader
+       (let ((fun (slot-definition-reader-function slotd)))
+         (declare (type function fun))
+         (lambda (class object slotd)
+           (declare (ignore class slotd))
+           (funcall fun object))))
+       (writer
+       (let ((fun (slot-definition-writer-function slotd)))
+         (declare (type function fun))
+         (lambda (new-value class object slotd)
+           (declare (ignore class slotd))
+           (funcall fun new-value object))))
+       (boundp
+       (let ((fun (slot-definition-boundp-function slotd)))
+         (declare (type function fun))
+         (lambda (class object slotd)
+           (declare (ignore class slotd))
+           (funcall fun object))))))
+    (t
+     (let* ((fsc-p (cond ((standard-class-p class) nil)
+                        ((funcallable-standard-class-p class) t)
+                        (t (error "~S is not a standard-class" class))))
+           (slot-name (slot-definition-name slotd))
+           (index (slot-definition-location slotd))
+           (function
+            (ecase name
+              (reader
+               #'make-optimized-std-slot-value-using-class-method-function)
+              (writer
+               #'make-optimized-std-setf-slot-value-using-class-method-function)
+              (boundp
+               #'make-optimized-std-slot-boundp-using-class-method-function))))
+       (declare (type function function))
+       (values (funcall function fsc-p slot-name index) index)))))
 
 (defun make-optimized-std-slot-value-using-class-method-function
     (fsc-p slot-name index)