X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=f7c5b62c9587c52a7699974c534230cf4d453581;hb=1bab7f87e5800ae7d0eed4e301de15125e72bd6f;hp=1baa5728347377832b054cd18c6f260c33aa033e;hpb=8f52542e9da8faa2c2650d37e8cba0f13c3b1c0a;p=sbcl.git

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 1baa572..f7c5b62 100644
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -56,15 +56,21 @@
     (setf reader-specializers (mapcar #'find-class reader-specializers))
     (setf writer-specializers (mapcar #'find-class writer-specializers))))
 
+(defmacro quiet-funcall (fun &rest args)
+  ;; Don't give a style-warning about undefined function here.
+  `(funcall (locally (declare (muffle-conditions style-warning))
+              ,fun)
+            ,@args))
+
 (defmacro accessor-slot-value (object slot-name &environment env)
   (aver (constantp slot-name env))
   (let* ((slot-name (constant-form-value slot-name env))
          (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)))))
+       (declare (ignore .ignore.))
+       (truly-the (values t &optional)
+                  (quiet-funcall #',reader-name ,object)))))
 
 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
   (aver (constantp slot-name env))
@@ -82,7 +88,7 @@
                    (ensure-accessor 'writer ',writer-name ',slot-name)))
                  (.new-value. ,new-value))
             (declare (ignore .ignore.))
-            (funcall #',writer-name .new-value. ,object)
+            (quiet-funcall #',writer-name .new-value. ,object)
             .new-value.)))
     (if bind-object
         `(let ,bind-object ,form)
@@ -205,20 +211,22 @@
                       (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)))
+                       (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))
@@ -226,21 +234,18 @@
                            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))
+                         ;; If we have a TYPE-CHECK-FUNCTION, call it.
+                         (let* (;; Note that the class of INSTANCE here 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 right type check function
+                                ;; from the wrapper instead of just closing over it.
+                                (wrapper (valid-wrapper-of instance))
                                 (type-check-function
-                                 (when slotd
-                                   (slot-definition-type-check-function slotd))))
+                                 (cadr (find-slot-cell wrapper slot-name))))
+                           (declare (type (or function null) type-check-function))
                            (when type-check-function
                              (funcall type-check-function new-value)))
                          ;; Then call the real writer.
@@ -469,7 +474,7 @@
     initargs))
 
 (defun make-std-writer-method-function (class-or-name slot-name)
-  (let* ((class (when (eq *boot-state* 'complete)
+  (let* ((class (when (eq **boot-state** 'complete)
                   (if (typep class-or-name 'class)
                       class-or-name
                       (find-class class-or-name nil))))
@@ -583,13 +588,13 @@
          (vector (make-array n :initial-element nil))
          (save-slot-location-p
           (or bootstrap
-              (when (eq 'complete *boot-state*)
+              (when (eq 'complete **boot-state**)
                 (let ((metaclass (class-of class)))
                   (or (eq metaclass *the-class-standard-class*)
                       (eq metaclass *the-class-funcallable-standard-class*))))))
          (save-type-check-function-p
           (unless bootstrap
-            (and save-slot-location-p (safe-p class)))))
+            (and (eq 'complete **boot-state**) (safe-p class)))))
     (flet ((add-to-vector (name slot)
              (declare (symbol name)
                       (optimize (sb-c::insert-array-bounds-checks 0)))
@@ -603,7 +608,7 @@
                                           (slot-definition-type-check-function slot))
                                         slot)
                             (svref vector index))))))
-      (if (eq 'complete *boot-state*)
+      (if (eq 'complete **boot-state**)
          (dolist (slot slots)
            (add-to-vector (slot-definition-name slot) slot))
          (dolist (slot slots)