From: Christophe Rhodes Date: Sat, 4 Sep 2010 08:01:27 +0000 (+0000) Subject: 1.0.42.32: fix for lp#611361 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b5cb7e8676a8bb88e647ceaf5f2571943b960c05;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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 --- 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"