1.0.42.32: fix for lp#611361

Only omit IGNORE declarations for required method parameters, not all
parameters.

diff --git a/NEWS b/NEWS
index 9335ee2..b24dc75 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -39,6 +39,8 @@ changes relative to sbcl-1.0.42
     (not in launchpad, reported by sykopomp in #lispgames)
   * bug fix: package-locks failed to protect against compile-time effects of
     DEFUN when the symbol previously had a macro definition. (lp#576637)
+  * bug fix: spurious ignore warnings even given (DECLARE IGNORE) in methods
+    when parameter bindings mutated.  (reported by Faré Rideau; lp #611361)
 
 changes in sbcl-1.0.42 relative to sbcl-1.0.41
 

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 47020a2..ecb3bcf 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -733,6 +733,7 @@ bootstrapping.
                                            ,call-next-method-p
                                            :next-method-p-p ,next-method-p-p
                                            :setq-p ,setq-p
+                                           :parameters-setqd ,parameters-setqd
                                            :method-cell ,method-cell
                                            :closurep ,closurep
                                            :applyp ,applyp)
@@ -967,7 +968,7 @@ bootstrapping.
 
 (defmacro bind-simple-lexical-method-functions
     ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p
-                                     closurep applyp method-cell))
+                                     parameters-setqd closurep applyp method-cell))
      &body body
      &environment env)
   (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
@@ -1318,6 +1319,7 @@ bootstrapping.
     ((args rest-arg next-method-call (&key
                                       call-next-method-p
                                       setq-p
+                                      parameters-setqd
                                       method-cell
                                       next-method-p-p
                                       closurep
@@ -1491,23 +1493,6 @@ bootstrapping.
                     (setq next-method-p-p t)
                     form)
                    ((memq (car form) '(setq multiple-value-setq))
-                    ;; FIXME: this is possibly a little strong as
-                    ;; conditions go.  Ideally we would want to detect
-                    ;; which, if any, of the method parameters are
-                    ;; being set, and communicate that information to
-                    ;; e.g. SPLIT-DECLARATIONS.  However, the brute
-                    ;; force method doesn't really cost much; a little
-                    ;; loss of discrimination over IGNORED variables
-                    ;; should be all.  -- CSR, 2004-07-01
-                    ;;
-                    ;; As of 2006-09-18 modified parameter bindings
-                    ;; are now tracked with more granularity than just
-                    ;; one SETQ-P flag, in order to disable SLOT-VALUE
-                    ;; optimizations for parameters that are SETQd.
-                    ;; The old binary SETQ-P flag is still used for
-                    ;; all other purposes, since as noted above, the
-                    ;; extra cost is minimal. -- JES, 2006-09-18
-                    ;;
                     ;; The walker will split (SETQ A 1 B 2) to
                     ;; separate (SETQ A 1) and (SETQ B 2) forms, so we
                     ;; only need to handle the simple case of SETQ

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index d009221..1a6a529 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -550,7 +550,7 @@
         (declare ,(make-pv-type-declaration '.pv.))
         ,@forms)))
 
-(defun split-declarations (body args maybe-reads-params-p)
+(defun split-declarations (body args req-args cnm-p parameters-setqd)
   (let ((inner-decls nil)
         (outer-decls nil)
         decl)
@@ -579,7 +579,7 @@
                            ;; args when a next-method is involved, to
                            ;; prevent compiler warnings about ignored
                            ;; args being read.
-                           (unless (and (eq 'ignore name) maybe-reads-params-p)
+                           (unless (and (eq 'ignore name) (member var req-args :test #'eq) (or cnm-p (member var parameters-setqd)))
                              (push var outers))
                            (push var inners)))
                      (when outers
@@ -677,7 +677,7 @@
          (outer-parameters req-args)
          ;; The lambda-list used by BIND-ARGS
          (bind-list lambda-list)
-         (setq-p (getf (cdr lmf-params) :setq-p))
+         (parameters-setqd (getf (cdr lmf-params) :parameters-setqd))
          (auxp (member '&aux bind-list))
          (call-next-method-p (getf (cdr lmf-params) :call-next-method-p)))
     ;; Try to use the normal function call machinery instead of BIND-ARGS
@@ -702,7 +702,7 @@
             bind-list req-args))
     (multiple-value-bind (outer-decls inner-decls body-sans-decls)
         (split-declarations
-         body outer-parameters (or call-next-method-p setq-p))
+         body outer-parameters req-args call-next-method-p parameters-setqd)
       (let* ((rest-arg (when restp
                          '.rest-arg.))
              (fmf-lambda-list (if rest-arg

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index ec9dffc..56fb8c3 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1872,4 +1872,20 @@
              (symbol-name s)))
     (assert (equal "FOO" (funcall 'lp-618387 :foo)))))
 
+(with-test (:name :pcl-spurious-ignore-warnings)
+  (defgeneric no-spurious-ignore-warnings (req &key key))
+  (handler-bind ((warning (lambda (x) (error "~A" x))))
+    (eval
+     '(defmethod no-spurious-ignore-warnings ((req number) &key key)
+       (declare (ignore key))
+       (check-type req integer))))
+  (defgeneric should-get-an-ignore-warning (req &key key))
+  (let ((warnings 0))
+    (handler-bind ((warning (lambda (c) (setq warnings 1) (muffle-warning c))))
+      (eval '(defmethod should-get-an-ignore-warning ((req integer) &key key)
+              (check-type req integer))))
+    (assert (= warnings 1))))
+
+
+
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 246fe56..110b44e 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.42.31"
+"1.0.42.32"