0.8.0.2:

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

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index aa82a0e..a5bf11b 100644 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -58,7 +58,7 @@
         (error "unrecognized instance type"))))
 
 (defun swap-wrappers-and-slots (i1 i2)
-  (sb-sys:without-interrupts
+  (with-pcl-lock                       ;FIXME is this sufficient?
    (cond ((std-instance-p i1)
          (let ((w1 (std-instance-wrapper i1))
                (s1 (std-instance-slots i1)))
@@ -116,14 +116,11 @@
        (slot-missing class object slot-name 'slot-value)
        (slot-value-using-class class object slot-definition))))
 
-(setf (gdefinition 'slot-value-normal) #'slot-value)
-
-(define-compiler-macro slot-value (object-form slot-name-form)
-  (if (and (constantp slot-name-form)
-          (let ((slot-name (eval slot-name-form)))
-            (and (symbolp slot-name) (symbol-package slot-name))))
-      `(accessor-slot-value ,object-form ,slot-name-form)
-      `(slot-value-normal ,object-form ,slot-name-form)))
+(define-compiler-macro slot-value (&whole form object slot-name)
+  (if (and (constantp slot-name)
+          (interned-symbol-p (eval slot-name)))
+      `(accessor-slot-value ,object ,slot-name)
+      form))
 
 (defun set-slot-value (object slot-name new-value)
   (let* ((class (class-of object))
@@ -133,16 +130,11 @@
        (setf (slot-value-using-class class object slot-definition)
              new-value))))
 
-(setf (gdefinition 'set-slot-value-normal) #'set-slot-value)
-
-(define-compiler-macro set-slot-value (object-form
-                                      slot-name-form
-                                      new-value-form)
-  (if (and (constantp slot-name-form)
-          (let ((slot-name (eval slot-name-form)))
-            (and (symbolp slot-name) (symbol-package slot-name))))
-      `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form)
-      `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form)))
+(define-compiler-macro set-slot-value (&whole form object slot-name new-value)
+  (if (and (constantp slot-name)
+          (interned-symbol-p (eval slot-name)))
+      `(accessor-set-slot-value ,object ,slot-name ,new-value)
+      form))
 
 (defun slot-boundp (object slot-name)
   (let* ((class (class-of object))
@@ -153,12 +145,11 @@
 
 (setf (gdefinition 'slot-boundp-normal) #'slot-boundp)
 
-(define-compiler-macro slot-boundp (object-form slot-name-form)
-  (if (and (constantp slot-name-form)
-          (let ((slot-name (eval slot-name-form)))
-            (and (symbolp slot-name) (symbol-package slot-name))))
-      `(accessor-slot-boundp ,object-form ,slot-name-form)
-      `(slot-boundp-normal ,object-form ,slot-name-form)))
+(define-compiler-macro slot-boundp (&whole form object slot-name)
+  (if (and (constantp slot-name)
+          (interned-symbol-p (eval slot-name)))
+      `(accessor-slot-boundp ,object ,slot-name)
+      form))
 
 (defun slot-makunbound (object slot-name)
   (let* ((class (class-of object))
@@ -276,7 +267,36 @@
        (error "~@<The slot ~S has neither :INSTANCE nor :CLASS allocation, ~
               so it can't be written by the default ~S method.~@:>"
              slotd 'slot-makunbound-using-class))))
-  nil)
+  object)
+
+(defmethod slot-value-using-class
+    ((class condition-class)
+     (object condition)
+     (slotd condition-effective-slot-definition))
+  (let ((fun (slot-definition-reader-function slotd)))
+    (declare (type function fun))
+    (funcall fun object)))
+
+(defmethod (setf slot-value-using-class)
+    (new-value
+     (class condition-class)
+     (object condition)
+     (slotd condition-effective-slot-definition))
+  (let ((fun (slot-definition-writer-function slotd)))
+    (declare (type function fun))
+    (funcall fun new-value object)))
+
+(defmethod slot-boundp-using-class
+    ((class condition-class)
+     (object condition)
+     (slotd condition-effective-slot-definition))
+  (let ((fun (slot-definition-boundp-function slotd)))
+    (declare (type function fun))
+    (funcall fun object)))
+
+(defmethod slot-makunbound-using-class ((class condition-class) object slot)
+  (error "attempt to unbind slot ~S in condition object ~S."
+        slot object))
 
 (defmethod slot-value-using-class
     ((class structure-class)
@@ -346,3 +366,7 @@
     (if constructor
        (funcall constructor)
        (error "can't allocate an instance of class ~S" (class-name class)))))
+
+(defmethod allocate-instance ((class condition-class) &rest initargs)
+  (declare (ignore initargs))
+  (make-condition (class-name class)))