1.0.36.4: muffle style-warnings for undefined slot writers

 * Reported by Frederik Tolf on sbcl-help.

diff --git a/NEWS b/NEWS
index 4fb76f8..2d74cd5 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,8 @@ changes relative to sbcl-1.0.36:
     in :INITIAL-CONTENTS. (lp#523612)
   * bug fix: FUNCTION-LAMBDA-EXPRESSION lost declarations from interpreted
     functions. (lp#524707)
+  * bug fix: bogus style warnings from certain (SETF SLOT-VALUE) and
+    WITH-SLOTS usages during compilation.
 
 changes in sbcl-1.0.36 relative to sbcl-1.0.35:
   * new feature: SB-EXT:TYPEXPAND-1, SB-EXT:TYPEXPAND, and

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index df80a18..f7c5b62 100644 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -56,18 +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)
-                 ;; Don't give a style-warning about undefined function here.
-                 (funcall (locally (declare (muffle-conditions style-warning))
-                            #',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))
@@ -85,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)

diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh
index bac5690..13d1c75 100644 (file)
--- a/tests/compiler.test.sh
+++ b/tests/compiler.test.sh
@@ -453,5 +453,13 @@ cat > $tmpfilename <<EOF
   (error "ERROR within EVAL-WHEN."))
 EOF
 expect_condition_during_compile sb-c:compiler-error $tmpfilename
+
+cat > $tmpfilename <<EOF
+(defun slot-name-incf (s)
+  (with-slots (no-such-slot) s
+    (incf no-such-slot)))
+EOF
+expect_clean_cload $tmpfilename
+
 # success
 exit $EXIT_TEST_WIN

diff --git a/version.lisp-expr b/version.lisp-expr
index 5a331b3..4ccec24 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.36.3"
+"1.0.36.4"