0.7.9.43:

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

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 9fc23ba..273805b 100644 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -23,32 +23,6 @@
 
 (in-package "SB-PCL")
 \f
-(defmacro slot-symbol (slot-name type)
-  `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
-       (or (get ,slot-name ',(ecase type
-                              (reader 'reader-symbol)
-                              (writer 'writer-symbol)
-                              (boundp 'boundp-symbol)))
-          (intern (format nil "~A ~A slot ~A"
-                          (package-name (symbol-package ,slot-name))
-                          (symbol-name ,slot-name)
-                          ,(symbol-name type))
-                  *slot-accessor-name-package*))
-       (progn
-        (error "Non-symbol and non-interned symbol slot name accessors~
-                are not yet implemented.")
-        ;;(make-symbol (format nil "~A ~A" ,slot-name ,type))
-        )))
-
-(defun slot-reader-symbol (slot-name)
-  (slot-symbol slot-name reader))
-
-(defun slot-writer-symbol (slot-name)
-  (slot-symbol slot-name writer))
-
-(defun slot-boundp-symbol (slot-name)
-  (slot-symbol slot-name boundp))
-
 (defmacro asv-funcall (sym slot-name type &rest args)
   (declare (ignore type))
   `(if (fboundp ',sym)
@@ -91,16 +65,8 @@
   (let ((slot-name (eval slot-name)))
     `(slot-boundp-normal ,object ',slot-name)))
 
-(defun structure-slot-boundp (object)
-  (declare (ignore object))
-  t)
-
 (defun make-structure-slot-boundp-function (slotd)
-  (let* ((reader (slot-definition-internal-reader-function slotd))
-        (fun (lambda (object)
-               (not (eq (funcall reader object) +slot-unbound+)))))
-    (declare (type function reader))
-    fun))
+  (lambda (object) (declare (ignore object)) t))
 
 (defun get-optimized-std-accessor-method-function (class slotd name)
   (if (structure-class-p class)
@@ -133,18 +99,21 @@
    (etypecase index
      (fixnum (if fsc-p
                 (lambda (instance)
+                  (check-obsolete-instance instance)
                   (let ((value (clos-slots-ref (fsc-instance-slots instance)
                                                index)))
                     (if (eq value +slot-unbound+)
                         (slot-unbound (class-of instance) instance slot-name)
                         value)))
                 (lambda (instance)
+                  (check-obsolete-instance instance)
                   (let ((value (clos-slots-ref (std-instance-slots instance)
                                              index)))
                     (if (eq value +slot-unbound+)
                         (slot-unbound (class-of instance) instance slot-name)
                         value)))))
      (cons   (lambda (instance)
+              (check-obsolete-instance instance)
               (let ((value (cdr index)))
                 (if (eq value +slot-unbound+)
                     (slot-unbound (class-of instance) instance slot-name)
@@ -157,13 +126,15 @@
    (etypecase index
      (fixnum (if fsc-p
                 (lambda (nv instance)
+                  (check-obsolete-instance instance)
                   (setf (clos-slots-ref (fsc-instance-slots instance) index)
                         nv))
                 (lambda (nv instance)
+                  (check-obsolete-instance instance)
                   (setf (clos-slots-ref (std-instance-slots instance) index)
                         nv))))
      (cons   (lambda (nv instance)
-              (declare (ignore instance))
+              (check-obsolete-instance instance)
               (setf (cdr index) nv))))
    `(writer ,slot-name)))
 
@@ -173,25 +144,25 @@
    (etypecase index
      (fixnum (if fsc-p
                 (lambda (instance)
+                  (check-obsolete-instance instance)
                   (not (eq (clos-slots-ref (fsc-instance-slots instance)
                                            index)
                            +slot-unbound+)))
                 (lambda (instance)
+                  (check-obsolete-instance instance)
                   (not (eq (clos-slots-ref (std-instance-slots instance)
                                            index)
                            +slot-unbound+)))))
      (cons (lambda (instance)
-            (declare (ignore instance))
+            (check-obsolete-instance instance)
             (not (eq (cdr index) +slot-unbound+)))))
    `(boundp ,slot-name)))
 
 (defun make-optimized-structure-slot-value-using-class-method-function (function)
   (declare (type function function))
   (lambda (class object slotd)
-    (let ((value (funcall function object)))
-      (if (eq value +slot-unbound+)
-         (slot-unbound class object (slot-definition-name slotd))
-         value))))
+    (declare (ignore class slotd))
+    (funcall function object)))
 
 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
   (declare (type function function))
@@ -199,11 +170,10 @@
     (declare (ignore class slotd))
     (funcall function nv object)))
 
-(defun make-optimized-structure-slot-boundp-using-class-method-function (function)
-  (declare (type function function))
+(defun make-optimized-structure-slot-boundp-using-class-method-function ()
   (lambda (class object slotd)
-    (declare (ignore class slotd))
-    (not (eq (funcall function object) +slot-unbound+))))
+    (declare (ignore class object slotd))
+    t))
 
 (defun get-optimized-std-slot-value-using-class-method-function (class
                                                                 slotd
@@ -214,8 +184,7 @@
                 (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
-                (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))))
@@ -239,7 +208,7 @@
     (fixnum (if fsc-p
                (lambda (class instance slotd)
                  (declare (ignore slotd))
-                 (unless (fsc-instance-p instance) (error "not fsc"))
+                 (check-obsolete-instance instance)
                  (let ((value (clos-slots-ref (fsc-instance-slots instance)
                                               index)))
                    (if (eq value +slot-unbound+)
@@ -247,7 +216,7 @@
                        value)))
                (lambda (class instance slotd)
                  (declare (ignore slotd))
-                 (unless (std-instance-p instance) (error "not std"))
+                 (check-obsolete-instance instance)
                  (let ((value (clos-slots-ref (std-instance-slots instance)
                                               index)))
                    (if (eq value +slot-unbound+)
@@ -255,6 +224,7 @@
                        value)))))
     (cons   (lambda (class instance slotd)
              (declare (ignore slotd))
+             (check-obsolete-instance instance)
              (let ((value (cdr index)))
                (if (eq value +slot-unbound+)
                    (slot-unbound class instance slot-name)
@@ -268,14 +238,17 @@
     (fixnum (if fsc-p
                (lambda (nv class instance slotd)
                  (declare (ignore class slotd))
+                 (check-obsolete-instance instance)
                  (setf (clos-slots-ref (fsc-instance-slots instance) index)
                        nv))
                (lambda (nv class instance slotd)
                  (declare (ignore class slotd))
+                 (check-obsolete-instance instance)
                  (setf (clos-slots-ref (std-instance-slots instance) index)
                        nv))))
     (cons  (lambda (nv class instance slotd)
-            (declare (ignore class instance slotd))
+            (declare (ignore class slotd))
+            (check-obsolete-instance instance)
             (setf (cdr index) nv)))))
 
 (defun make-optimized-std-slot-boundp-using-class-method-function
@@ -286,14 +259,17 @@
     (fixnum (if fsc-p
                (lambda (class instance slotd)
                  (declare (ignore class slotd))
+                 (check-obsolete-instance instance)
                  (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
                           +slot-unbound+)))
                (lambda (class instance slotd)
                  (declare (ignore class slotd))
+                 (check-obsolete-instance instance)
                  (not (eq (clos-slots-ref (std-instance-slots instance) index)
                           +slot-unbound+)))))
     (cons   (lambda (class instance slotd)
-             (declare (ignore class instance slotd))
+             (declare (ignore class slotd))
+             (check-obsolete-instance instance)
              (not (eq (cdr index) +slot-unbound+))))))
 
 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)