From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 1 Dec 2011 09:53:32 +0000 (+0200)
Subject: less rebindings in defmethods
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b7d70307b86d305c654f0a24f8a416b082f275a7;p=sbcl.git

less rebindings in defmethods

  PCL needs to rebind DEFMETHOD arguments when they are assigned to:

  * CALL-NEXT-METHOD needs the originals.

  * We apply an implicit declaration to the original from the specializer,
    which an assignment can violate.

  There is, however, no need to bind everything simply because /something/ is
  assigned to.

  Fixed lp#898331.
---

diff --git a/NEWS b/NEWS
index 4ef4ab1..8c3eecb 100644
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,9 @@ changes relative to sbcl-1.0.54:
     by ANSI. (lp#894202)
   * bug fix: SUBTYPEP tests involving forward-referenced classes no longer
     bogusly report NIL, T.
+  * bug fix: bogus style-warnings for DEFMETHOD forms that both declared some
+    required arguments ignored and performed assignments to others.
+    (lp#898331)
 
 changes in sbcl-1.0.54 relative to sbcl-1.0.53:
   * minor incompatible changes:
diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index c794df4..1e1518a 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -1312,9 +1312,8 @@ bootstrapping.
                                       applyp))
      &body body
      &environment env)
-  (let* ((all-params (append args (when rest-arg (list rest-arg))))
-         (rebindings (when (or setq-p call-next-method-p)
-                       (mapcar (lambda (x) (list x x)) all-params))))
+  (let* ((rebindings (when (or setq-p call-next-method-p)
+                       (mapcar (lambda (x) (list x x)) parameters-setqd))))
     (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
         `(locally
              ,@body)
@@ -1337,7 +1336,6 @@ bootstrapping.
                          (declare (optimize (sb-c:insert-step-conditions 0)))
                          (not (null ,next-method-call))))))
            (let ,rebindings
-             ,@(when rebindings `((declare (ignorable ,@all-params))))
              ,@body)))))
 
 ;;; CMUCL comment (Gerd Moellmann):
diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index db9882c..2fa4b85 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -663,7 +663,9 @@
                            ;; args when a next-method is involved, to
                            ;; prevent compiler warnings about ignored
                            ;; args being read.
-                           (unless (and (eq 'ignore name) (member var req-args :test #'eq) (or cnm-p (member var parameters-setqd)))
+                           (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
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 1e383cd..24b24d9 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1911,4 +1911,13 @@
                 (warning ()
                   :good)))))
 
+(with-test (:name :bug-898331)
+  (handler-bind ((warning #'error))
+    (eval `(defgeneric bug-898331 (request type remaining-segment-requests all-requests)))
+    (eval `(defmethod bug-898331 ((request cons) (type (eql :cancel))
+                                  remaining-segment-requests
+                                  all-segment-requests)
+             (declare (ignore all-segment-requests))
+             (check-type request t)))))
+
 ;;;; success