1.0.6.12: Improve user-subclassed SB-MOP:SPECIALIZER support

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

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 4ee0df1..8abdb89 100644 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -23,366 +23,501 @@
 
 (in-package "SB-PCL")
 \f
 
 (in-package "SB-PCL")
 \f

-(defmacro asv-funcall (sym slot-name type &rest args)
-  (declare (ignore type))
-  `(if (fboundp ',sym)
-       (,sym ,@args)
-       (no-slot ',sym ',slot-name)))
-
-(defun no-slot (sym slot-name)
-  (error "No class has a slot named ~S (~S has no function binding)."
-        slot-name sym))
+(let ((reader-specializers '(slot-object))
+      (writer-specializers '(t slot-object)))
+  (defun ensure-accessor (type fun-name slot-name)
+    (unless (fboundp fun-name)
+      (multiple-value-bind (lambda-list specializers method-class initargs doc)
+          (ecase type
+            ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING
+            ;; behaviour for non-slot-objects too?
+            (reader
+             (values '(object) reader-specializers 'global-reader-method
+                     (make-std-reader-method-function 'slot-object slot-name)
+                     "automatically-generated reader method"))
+            (writer
+             (values '(new-value object) writer-specializers
+                     'global-writer-method
+                     (make-std-writer-method-function 'slot-object slot-name)
+                     "automatically-generated writer method"))
+            (boundp
+             (values '(object) reader-specializers 'global-boundp-method
+                     (make-std-boundp-method-function 'slot-object slot-name)
+                     "automatically-generated boundp method")))
+        (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list)))
+          (add-method gf (make-a-method method-class
+                                        () lambda-list specializers
+                                        initargs doc :slot-name slot-name)))))
+    t)
+  ;; KLUDGE: this is maybe PCL bootstrap mechanism #6 or #7, invented
+  ;; by CSR in June 2007.  Making the bootstrap sane is getting higher
+  ;; on the "TODO: URGENT" list.
+  (defun !fix-ensure-accessor-specializers ()
+    (setf reader-specializers (mapcar #'find-class reader-specializers))
+    (setf writer-specializers (mapcar #'find-class writer-specializers))))

 
 (defmacro accessor-slot-value (object slot-name)
 
 (defmacro accessor-slot-value (object slot-name)

-  (unless (constantp slot-name)
-    (error "~S requires its slot-name argument to be a constant"
-          'accessor-slot-value))
-  (let* ((slot-name (eval slot-name))
-        (sym (slot-reader-symbol slot-name)))
-    `(asv-funcall ,sym ,slot-name reader ,object)))
+  (aver (constantp slot-name))
+  (let* ((slot-name (constant-form-value slot-name))
+         (reader-name (slot-reader-name slot-name)))
+    `(let ((.ignore. (load-time-value
+                      (ensure-accessor 'reader ',reader-name ',slot-name))))
+      (declare (ignore .ignore.))
+      (truly-the (values t &optional)
+                 (funcall #',reader-name ,object)))))

 
 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
 
 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)

-  (unless (constantp slot-name)
-    (error "~S requires its slot-name argument to be a constant"
-          'accessor-set-slot-value))
+  (aver (constantp slot-name))

   (setq object (macroexpand object env))
   (setq slot-name (macroexpand slot-name env))
   (setq object (macroexpand object env))
   (setq slot-name (macroexpand slot-name env))

-  (let* ((slot-name (eval slot-name))
-        (bindings (unless (or (constantp new-value) (atom new-value))
-                    (let ((object-var (gensym)))
-                      (prog1 `((,object-var ,object))
-                        (setq object object-var)))))
-        (sym (slot-writer-symbol slot-name))
-        (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
+  (let* ((slot-name (constant-form-value slot-name))
+         (bindings (unless (or (constantp new-value) (atom new-value))
+                     (let ((object-var (gensym)))
+                       (prog1 `((,object-var ,object))
+                         (setq object object-var)))))
+         (writer-name (slot-writer-name slot-name))
+         (form
+          `(let ((.ignore.
+                  (load-time-value
+                   (ensure-accessor 'writer ',writer-name ',slot-name)))
+                 (.new-value. ,new-value))
+            (declare (ignore .ignore.))
+            (funcall #',writer-name .new-value. ,object)
+            .new-value.)))

     (if bindings
     (if bindings

-       `(let ,bindings ,form)
-       form)))
+        `(let ,bindings ,form)
+        form)))

 
 (defmacro accessor-slot-boundp (object slot-name)
 
 (defmacro accessor-slot-boundp (object slot-name)

-  (unless (constantp slot-name)
-    (error "~S requires its slot-name argument to be a constant"
-          'accessor-slot-boundp))
-  (let ((slot-name (eval slot-name)))
-    `(slot-boundp-normal ,object ',slot-name)))
-
-(defun structure-slot-boundp (object)
-  (declare (ignore object))
-  t)
+  (aver (constantp slot-name))
+  (let* ((slot-name (constant-form-value slot-name))
+         (boundp-name (slot-boundp-name slot-name)))
+    `(let ((.ignore. (load-time-value
+                      (ensure-accessor 'boundp ',boundp-name ',slot-name))))
+      (declare (ignore .ignore.))
+      (funcall #',boundp-name ,object))))

 
 (defun make-structure-slot-boundp-function (slotd)
 
 (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))
+  (declare (ignore slotd))
+  (lambda (object)
+    (declare (ignore object))
+    t))
+
+(define-condition instance-structure-protocol-error
+    (reference-condition error)
+  ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
+   (fun :initarg :fun :reader instance-structure-protocol-error-fun))
+  (:report
+   (lambda (c s)
+     (format s "~@<The slot ~S has neither ~S nor ~S ~
+                allocation, so it can't be ~A by the default ~
+                ~S method.~@:>"
+             (instance-structure-protocol-error-slotd c)
+             :instance :class
+             (cond
+               ((member (instance-structure-protocol-error-fun c)
+                        '(slot-value-using-class slot-boundp-using-class))
+                "read")
+               (t "written"))
+             (instance-structure-protocol-error-fun c)))))
+
+(defun instance-structure-protocol-error (slotd fun)
+  (error 'instance-structure-protocol-error
+         :slotd slotd :fun fun
+         :references (list `(:amop :generic-function ,fun)
+                           '(:amop :section (5 5 3)))))

 
 (defun get-optimized-std-accessor-method-function (class slotd name)
 
 (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))
+            (location (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)))
+            ;; KLUDGE: we need this slightly hacky calling convention
+            ;; for these functions for bootstrapping reasons: see
+            ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
+            ;; 2004-07-12
+            (value (funcall function fsc-p slotd slot-name location)))
+       (declare (type function function))
+       (values value (slot-definition-location slotd))))))

 
 

-(defun make-optimized-std-reader-method-function (fsc-p slot-name index)
+(defun make-optimized-std-reader-method-function
+    (fsc-p slotd slot-name location)

   (declare #.*optimize-speed*)
   (set-fun-name
   (declare #.*optimize-speed*)
   (set-fun-name

-   (etypecase index
-     (fixnum (if fsc-p
-                (lambda (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)
-                  (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)
-              (let ((value (cdr index)))
-                (if (eq value +slot-unbound+)
-                    (slot-unbound (class-of instance) instance slot-name)
-                    value)))))
+   (etypecase location
+     (fixnum
+      (if fsc-p
+          (lambda (instance)
+            (check-obsolete-instance instance)
+            (let ((value (clos-slots-ref (fsc-instance-slots instance)
+                                         location)))
+              (if (eq value +slot-unbound+)
+                  (values
+                   (slot-unbound (class-of instance) instance slot-name))
+                  value)))
+          (lambda (instance)
+            (check-obsolete-instance instance)
+            (let ((value (clos-slots-ref (std-instance-slots instance)
+                                         location)))
+              (if (eq value +slot-unbound+)
+                  (values
+                   (slot-unbound (class-of instance) instance slot-name))
+                  value)))))
+     (cons
+      (lambda (instance)
+        (check-obsolete-instance instance)
+        (let ((value (cdr location)))
+          (if (eq value +slot-unbound+)
+              (values (slot-unbound (class-of instance) instance slot-name))
+              value))))
+     (null
+      (lambda (instance)
+        (instance-structure-protocol-error slotd 'slot-value-using-class))))

    `(reader ,slot-name)))
 
    `(reader ,slot-name)))
 

-(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
+(defun make-optimized-std-writer-method-function
+    (fsc-p slotd slot-name location)

   (declare #.*optimize-speed*)
   (declare #.*optimize-speed*)

-  (set-fun-name
-   (etypecase index
-     (fixnum (if fsc-p
-                (lambda (nv instance)
-                  (setf (clos-slots-ref (fsc-instance-slots instance) index)
-                        nv))
-                (lambda (nv instance)
-                  (setf (clos-slots-ref (std-instance-slots instance) index)
-                        nv))))
-     (cons   (lambda (nv instance)
-              (declare (ignore instance))
-              (setf (cdr index) nv))))
-   `(writer ,slot-name)))
+  (let* ((safe-p (and slotd
+                      (slot-definition-class slotd)
+                      (safe-p (slot-definition-class slotd))))
+         (writer-fun (etypecase location
+                       (fixnum (if fsc-p
+                                   (lambda (nv instance)
+                                     (check-obsolete-instance instance)
+                                     (setf (clos-slots-ref (fsc-instance-slots instance)
+                                                           location)
+                                           nv))
+                                   (lambda (nv instance)
+                                     (check-obsolete-instance instance)
+                                     (setf (clos-slots-ref (std-instance-slots instance)
+                                                           location)
+                                           nv))))
+                       (cons (lambda (nv instance)
+                               (check-obsolete-instance instance)
+                               (setf (cdr location) nv)))
+                       (null
+                        (lambda (nv instance)
+                          (declare (ignore nv instance))
+                          (instance-structure-protocol-error
+                           slotd
+                           '(setf slot-value-using-class))))))
+         (checking-fun (lambda (new-value instance)
+                         (check-obsolete-instance instance)
+                         ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it.
+                         (let* (;; Note that this CLASS is not neccessarily
+                                ;; the SLOT-DEFINITION-CLASS of the
+                                ;; SLOTD passed to M-O-S-W-M-F, since it's
+                                ;; e.g. possible for a subclass to define
+                                ;; a slot of the same name but with no
+                                ;; accessors. So we need to fetch the SLOTD
+                                ;; when CHECKING-FUN is called, instead of
+                                ;; just closing over it.
+                                (class (class-of instance))
+                                (slotd (find-slot-definition class slot-name))
+                                (type-check-function
+                                 (when slotd
+                                   (slot-definition-type-check-function slotd))))
+                           (when type-check-function
+                             (funcall type-check-function new-value)))
+                         ;; Then call the real writer.
+                         (funcall writer-fun new-value instance))))
+    (set-fun-name (if safe-p
+                      checking-fun
+                      writer-fun)
+                  `(writer ,slot-name))))

 
 

-(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
+(defun make-optimized-std-boundp-method-function
+    (fsc-p slotd slot-name location)

   (declare #.*optimize-speed*)
   (set-fun-name
   (declare #.*optimize-speed*)
   (set-fun-name

-   (etypecase index
+   (etypecase location

      (fixnum (if fsc-p
      (fixnum (if fsc-p

-                (lambda (instance)
-                  (not (eq (clos-slots-ref (fsc-instance-slots instance)
-                                           index)
-                           +slot-unbound+)))
-                (lambda (instance)
-                  (not (eq (clos-slots-ref (std-instance-slots instance)
-                                           index)
-                           +slot-unbound+)))))
+                 (lambda (instance)
+                   (check-obsolete-instance instance)
+                   (not (eq (clos-slots-ref (fsc-instance-slots instance)
+                                            location)
+                            +slot-unbound+)))
+                 (lambda (instance)
+                   (check-obsolete-instance instance)
+                   (not (eq (clos-slots-ref (std-instance-slots instance)
+                                            location)
+                            +slot-unbound+)))))

      (cons (lambda (instance)
      (cons (lambda (instance)

-            (declare (ignore instance))
-            (not (eq (cdr index) +slot-unbound+)))))
+             (check-obsolete-instance instance)
+             (not (eq (cdr location) +slot-unbound+))))
+     (null
+      (lambda (instance)
+        (instance-structure-protocol-error slotd 'slot-boundp-using-class))))

    `(boundp ,slot-name)))
 
    `(boundp ,slot-name)))
 

-(defun make-optimized-structure-slot-value-using-class-method-function (function)
+(defun make-optimized-structure-slot-value-using-class-method-function
+    (function)

   (declare (type function function))
   (lambda (class object slotd)
   (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)
+(defun make-optimized-structure-setf-slot-value-using-class-method-function
+    (function)

   (declare (type function function))
   (lambda (nv class object slotd)
     (declare (ignore class slotd))
     (funcall function nv object)))
 
   (declare (type function function))
   (lambda (nv class object slotd)
     (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)
   (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
-                                                                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
-                (slot-definition-internal-writer-function slotd))))
-      (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))))
+            (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 slotd)
+               (slot-definition-location slotd))))))

 
 

-(defun make-optimized-std-slot-value-using-class-method-function
-    (fsc-p slot-name index)
+(defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)

   (declare #.*optimize-speed*)
   (declare #.*optimize-speed*)

-  (etypecase index
-    (fixnum (if fsc-p
-               (lambda (class instance slotd)
-                 (declare (ignore slotd))
-                 (unless (fsc-instance-p instance) (error "not fsc"))
-                 (let ((value (clos-slots-ref (fsc-instance-slots instance)
-                                              index)))
-                   (if (eq value +slot-unbound+)
-                       (slot-unbound class instance slot-name)
-                       value)))
-               (lambda (class instance slotd)
-                 (declare (ignore slotd))
-                 (unless (std-instance-p instance) (error "not std"))
-                 (let ((value (clos-slots-ref (std-instance-slots instance)
-                                              index)))
-                   (if (eq value +slot-unbound+)
-                       (slot-unbound class instance slot-name)
-                       value)))))
-    (cons   (lambda (class instance slotd)
-             (declare (ignore slotd))
-             (let ((value (cdr index)))
-               (if (eq value +slot-unbound+)
-                   (slot-unbound class instance slot-name)
-                   value))))))
+  (let ((location (slot-definition-location slotd))
+        (slot-name (slot-definition-name slotd)))
+    (etypecase location
+      (fixnum (if fsc-p
+                  (lambda (class instance slotd)
+                    (declare (ignore slotd))
+                    (check-obsolete-instance instance)
+                    (let ((value (clos-slots-ref (fsc-instance-slots instance)
+                                                 location)))
+                      (if (eq value +slot-unbound+)
+                          (values (slot-unbound class instance slot-name))
+                          value)))
+                  (lambda (class instance slotd)
+                    (declare (ignore slotd))
+                    (check-obsolete-instance instance)
+                    (let ((value (clos-slots-ref (std-instance-slots instance)
+                                                 location)))
+                      (if (eq value +slot-unbound+)
+                          (values (slot-unbound class instance slot-name))
+                          value)))))
+      (cons (lambda (class instance slotd)
+              (declare (ignore slotd))
+              (check-obsolete-instance instance)
+              (let ((value (cdr location)))
+                (if (eq value +slot-unbound+)
+                    (values (slot-unbound class instance slot-name))
+                    value))))
+      (null
+       (lambda (class instance slotd)
+         (declare (ignore class instance))
+         (instance-structure-protocol-error slotd 'slot-value-using-class))))))

 
 (defun make-optimized-std-setf-slot-value-using-class-method-function
 
 (defun make-optimized-std-setf-slot-value-using-class-method-function

-    (fsc-p slot-name index)
+    (fsc-p slotd)

   (declare #.*optimize-speed*)
   (declare #.*optimize-speed*)

-  (declare (ignore slot-name))
-  (etypecase index
-    (fixnum (if fsc-p
-               (lambda (nv class instance slotd)
-                 (declare (ignore class slotd))
-                 (setf (clos-slots-ref (fsc-instance-slots instance) index)
-                       nv))
-               (lambda (nv class instance slotd)
-                 (declare (ignore class slotd))
-                 (setf (clos-slots-ref (std-instance-slots instance) index)
-                       nv))))
-    (cons  (lambda (nv class instance slotd)
-            (declare (ignore class instance slotd))
-            (setf (cdr index) nv)))))
+  (let ((location (slot-definition-location slotd))
+        (type-check-function
+         (when (and slotd
+                    (slot-definition-class slotd)
+                    (safe-p (slot-definition-class slotd)))
+           (slot-definition-type-check-function slotd))))
+    (macrolet ((make-mf-lambda (&body body)
+                 `(lambda (nv class instance slotd)
+                    (declare (ignore class slotd))
+                    (check-obsolete-instance instance)
+                    ,@body))
+               (make-mf-lambdas (&body body)
+                 ;; Having separate lambdas for the NULL / not-NULL cases of
+                 ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
+                 ;; for CLOS typechecking when it's not in use.
+                 `(if type-check-function
+                      (make-mf-lambda
+                       (funcall (the function type-check-function) nv)
+                       ,@body)
+                      (make-mf-lambda
+                       ,@body))))
+      (etypecase location
+        (fixnum
+         (if fsc-p
+             (make-mf-lambdas
+              (setf (clos-slots-ref (fsc-instance-slots instance) location)
+                    nv))
+             (make-mf-lambdas
+              (setf (clos-slots-ref (std-instance-slots instance) location)
+                    nv))))
+        (cons
+         (make-mf-lambdas (setf (cdr location) nv)))
+        (null (lambda (nv class instance slotd)
+                (declare (ignore nv class instance))
+                (instance-structure-protocol-error
+                 slotd '(setf slot-value-using-class))))))))

 
 (defun make-optimized-std-slot-boundp-using-class-method-function
 
 (defun make-optimized-std-slot-boundp-using-class-method-function

-    (fsc-p slot-name index)
+    (fsc-p slotd)

   (declare #.*optimize-speed*)
   (declare #.*optimize-speed*)

-  (declare (ignore slot-name))
-  (etypecase index
-    (fixnum (if fsc-p
-               (lambda (class instance slotd)
-                 (declare (ignore class slotd))
-                 (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
-                          +slot-unbound+)))
-               (lambda (class instance slotd)
-                 (declare (ignore class slotd))
-                 (not (eq (clos-slots-ref (std-instance-slots instance) index)
-                          +slot-unbound+)))))
-    (cons   (lambda (class instance slotd)
-             (declare (ignore class instance slotd))
-             (not (eq (cdr index) +slot-unbound+))))))
+  (let ((location (slot-definition-location slotd)))
+    (etypecase location
+      (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) location)
+                      +slot-unbound+)))
+           (lambda (class instance slotd)
+             (declare (ignore class slotd))
+             (check-obsolete-instance instance)
+             (not (eq (clos-slots-ref (std-instance-slots instance) location)
+                      +slot-unbound+)))))
+      (cons (lambda (class instance slotd)
+              (declare (ignore class slotd))
+              (check-obsolete-instance instance)
+              (not (eq (cdr location) +slot-unbound+))))
+      (null
+       (lambda (class instance slotd)
+         (declare (ignore class instance))
+         (instance-structure-protocol-error slotd
+                                            'slot-boundp-using-class))))))

 
 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
   (macrolet ((emf-funcall (emf &rest args)
 
 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
   (macrolet ((emf-funcall (emf &rest args)

-              `(invoke-effective-method-function ,emf nil ,@args)))
+               `(invoke-effective-method-function ,emf nil
+                                                  :required-args ,args)))

     (set-fun-name
      (case name
        (reader (lambda (instance)
     (set-fun-name
      (case name
        (reader (lambda (instance)

-                (emf-funcall sdfun class instance slotd)))
+                 (emf-funcall sdfun class instance slotd)))

        (writer (lambda (nv instance)
        (writer (lambda (nv instance)

-                (emf-funcall sdfun nv class instance slotd)))
+                 (emf-funcall sdfun nv class instance slotd)))

        (boundp (lambda (instance)
        (boundp (lambda (instance)

-                (emf-funcall sdfun class instance slotd))))
+                 (emf-funcall sdfun class instance slotd))))

      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
      `(,name ,(class-name class) ,(slot-definition-name slotd)))))

-
-(defun make-internal-reader-method-function (class-name slot-name)
-  (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
-        (make-method-function
-         (lambda (instance)
-           (let ((wrapper (get-instance-wrapper-or-nil instance)))
-             (if wrapper
-                 (let* ((class (wrapper-class* wrapper))
-                        (index (or (instance-slot-index wrapper slot-name)
-                                   (assq slot-name
-                                         (wrapper-class-slots wrapper)))))
-                   (typecase index
-                     (fixnum   
-                      (let ((value (clos-slots-ref (get-slots instance)
-                                                   index)))
-                        (if (eq value +slot-unbound+)
-                            (slot-unbound (class-of instance)
-                                          instance
-                                          slot-name)
-                            value)))
-                     (cons
-                      (let ((value (cdr index)))
-                        (if (eq value +slot-unbound+)
-                            (slot-unbound (class-of instance)
-                                          instance
-                                          slot-name)
-                            value)))
-                     (t
-                      (error "~@<The wrapper for class ~S does not have ~
-                               the slot ~S~@:>"
-                             class slot-name))))
-                 (slot-value instance slot-name)))))))

 \f
 \f

-(defun make-std-reader-method-function (class-name slot-name)
-  (let* ((pv-table-symbol (gensym))
-        (initargs (copy-tree
-                   (make-method-function
-                    (lambda (instance)
-                      (pv-binding1 (.pv. .calls.
-                                         (symbol-value pv-table-symbol)
-                                         (instance) (instance-slots))
-                        (instance-read-internal
-                         .pv. instance-slots 1
-                         (slot-value instance slot-name))))))))
-    (setf (getf (getf initargs :plist) :slot-name-lists)
-         (list (list nil slot-name)))
-    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
-    (list* :method-spec `(reader-method ,class-name ,slot-name)
-          initargs)))
-
-(defun make-std-writer-method-function (class-name slot-name)
-  (let* ((pv-table-symbol (gensym))
-        (initargs (copy-tree
-                   (make-method-function
-                    (lambda (nv instance)
-                      (pv-binding1 (.pv. .calls.
-                                         (symbol-value pv-table-symbol)
-                                         (instance) (instance-slots))
-                        (instance-write-internal
-                         .pv. instance-slots 1 nv
-                         (setf (slot-value instance slot-name) nv))))))))
-    (setf (getf (getf initargs :plist) :slot-name-lists)
-         (list nil (list nil slot-name)))
-    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
-    (list* :method-spec `(writer-method ,class-name ,slot-name)
-          initargs)))
-
-(defun make-std-boundp-method-function (class-name slot-name)
-  (let* ((pv-table-symbol (gensym))
-        (initargs (copy-tree
-                   (make-method-function
-                    (lambda (instance)
-                      (pv-binding1 (.pv. .calls.
-                                         (symbol-value pv-table-symbol)
-                                         (instance) (instance-slots))
-                         (instance-boundp-internal
-                          .pv. instance-slots 1
-                          (slot-boundp instance slot-name))))))))
-    (setf (getf (getf initargs :plist) :slot-name-lists)
-         (list (list nil slot-name)))
-    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
-    (list* :method-spec `(boundp-method ,class-name ,slot-name)
-          initargs)))
+(defun make-std-reader-method-function (class-or-name slot-name)
+  (declare (ignore class-or-name))
+  (let* ((initargs (copy-tree
+                    (make-method-function
+                     (lambda (instance)
+                       (pv-binding1 (.pv. .calls.
+                                          (bug "Please report this")
+                                          (instance) (instance-slots))
+                         (instance-read-internal
+                          .pv. instance-slots 0
+                          (slot-value instance slot-name))))))))
+    (setf (getf (getf initargs 'plist) :slot-name-lists)
+          (list (list nil slot-name)))
+    initargs))

 
 

-(defun initialize-internal-slot-gfs (slot-name &optional type)
-  (when (or (null type) (eq type 'reader))
-    (let* ((name (slot-reader-symbol slot-name))
-          (gf (ensure-generic-function name)))
-      (unless (generic-function-methods gf)
-       (add-reader-method *the-class-slot-object* gf slot-name))))
-  (when (or (null type) (eq type 'writer))
-    (let* ((name (slot-writer-symbol slot-name))
-          (gf (ensure-generic-function name)))
-      (unless (generic-function-methods gf)
-       (add-writer-method *the-class-slot-object* gf slot-name))))
-  nil)
+(defun make-std-writer-method-function (class-or-name slot-name)
+  (let* ((class (when (eq *boot-state* 'complete)
+                  (if (typep class-or-name 'class)
+                      class-or-name
+                      (find-class class-or-name nil))))
+         (safe-p (and class
+                      (safe-p class)))
+         (check-fun (lambda (new-value instance)
+                      (let* ((class (class-of instance))
+                             (slotd (find-slot-definition class slot-name))
+                             (type-check-function
+                              (when slotd
+                                (slot-definition-type-check-function slotd))))
+                        (when type-check-function
+                          (funcall type-check-function new-value)))))
+         (initargs (copy-tree
+                    (if safe-p
+                        (make-method-function
+                         (lambda (nv instance)
+                           (funcall check-fun nv instance)
+                           (pv-binding1 (.pv. .calls.
+                                              (bug "Please report this")
+                                              (instance) (instance-slots))
+                             (instance-write-internal
+                              .pv. instance-slots 0 nv
+                              (setf (slot-value instance slot-name) nv)))))
+                        (make-method-function
+                         (lambda (nv instance)
+                           (pv-binding1 (.pv. .calls.
+                                              (bug "Please report this")
+                                              (instance) (instance-slots))
+                             (instance-write-internal
+                              .pv. instance-slots 0 nv
+                              (setf (slot-value instance slot-name) nv)))))))))
+    (setf (getf (getf initargs 'plist) :slot-name-lists)
+          (list nil (list nil slot-name)))
+    initargs))

 
 

-(defun initialize-internal-slot-gfs* (readers writers boundps)
-  (dolist (reader readers)
-    (initialize-internal-slot-gfs reader 'reader))
-  (dolist (writer writers)
-    (initialize-internal-slot-gfs writer 'writer))
-  (dolist (boundp boundps)
-    (initialize-internal-slot-gfs boundp 'boundp)))
+(defun make-std-boundp-method-function (class-or-name slot-name)
+  (declare (ignore class-or-name))
+  (let* ((initargs (copy-tree
+                    (make-method-function
+                     (lambda (instance)
+                       (pv-binding1 (.pv. .calls.
+                                          (bug "Please report this")
+                                          (instance) (instance-slots))
+                          (instance-boundp-internal
+                           .pv. instance-slots 0
+                           (slot-boundp instance slot-name))))))))
+    (setf (getf (getf initargs 'plist) :slot-name-lists)
+          (list (list nil slot-name)))
+    initargs))