Bug in defaulted keyword arguments to setf methods

[Rob Pettengill <rcp%sw.MCC.COM@MCC.COM>]

Example:

<cl> (use-package 'pcl)

T 
<cl> (defclass foo () ((a)))

#<Class FOO 22167551> 
<cl> (defmethod n-a ((self foo) &key (n 2)) (* n (slot-value self 'a)))

#<Method N-A (FOO) 22203641> 
<cl> (defmethod-setf n-a ((self foo) &key (n 2)) (new-val)
       (setf (slot-value self 'a) (/ new-val n)))

#<Method (SETF N-A) (FOO) 22214461> 
<cl> (setq foo (make-instance 'foo :a 7))

#<Standard-Instance 22223151> 
<cl> (n-a foo)

14 
<cl> (n-a foo :n 3)

21 
<cl> (setf (n-a foo) 24)

Continuable error: attempt to call `N' which is an undefined function.
If continued with :continue, prompt for a new function.
[1c] <cl> :zo
Evaluation stack:

 ->(CERROR "prompt for a new function." "attempt to call `~s' which is an
undefined function." N)
   (LET* ((SELF (CAR (CDR EXCL::%ACCESS-ARGLIST))) (#:G229 (CDR (CDR
EXCL::%ACCESS-ARGLIST))) #:G230 (N (COND ((SETQ #:G230 (EXCL::FIND-KEYWORD #
#:G229)) (CAR #:G230)) (T 2)))) (EXCL::KEYWORD-TEST #:G229 '(:N)) (LIST '|setf
N-A| SELF NEW-VAL (N 2)))
... more older frames ...

The problem is that the setf function is trying to eval (n 2) rather
than n.  I traced this problem to do-do-defmethod-setf-defsetf in the
file defs.lisp.  This function appears to deal only with the "&key
foo" case and not the "&key (foo t)" or the "&key ((:foo-key foo) t)"
case.  I came up with the following quick fix.  I also think that
there may be a problem when &allow-other-keys are used with several
setf methods for the same generic function.  The problem and fix
appear to be the same in both the 8/27/87 and 1/11/88 versions of pcl.

(IN-PACKAGE 'PCL)		; in this package

;;; fix for pcl file defs.lisp in the 8/27/87 and 1/11/88 versions so
;;; that &key arguments in setf methods are more correctly handled

(defun do-defmethod-setf-defsetf (generic-function-name
				  arglist
				  &optional (new-value-arglist '(new-value)))
  (when (member '&aux arglist)
    (setq arglist (reverse arglist))
    (loop (when (eq (pop arglist) '&aux)
	    (return (setq arglist (nreverse arglist))))))
  (let* ((setf-name (pcl::get-setf-generic-function-name generic-function-name))
	 (setf-ll (pcl::make-setf-method-lambda-list arglist new-value-arglist)))
    (do-defsetf generic-function-name
		arglist		
		new-value-arglist
		``(,',setf-name
		       ;; formerly we had
		       ;; ,,@(remove-if #'(lambda (x)
		       ;;                   (member x lambda-list-keywords))
		       ;;      setf-ll)
		       ;; which did not handle keyword args with initial values
		       ;; There is probably still a problem with
		       ;; &allow-other-keys keywords from previously defined
		       ;; setf methods.
		   ,,@(let ((optional-or-key nil))
			(mapcan
			  #'(lambda (arg)
			      (cond
				((eq arg '&optional)
				 (setq optional-or-key :opt) nil)
				((eq arg '&key)
				 (setq optional-or-key :key) nil)
				((member arg lambda-list-keywords) nil)
				(t
				  (let ((karg
					   (if (listp arg) (first arg) arg)))
				    (case optional-or-key
				      (:opt (list karg))
				      (:key
					(if (listp karg) karg
					  (list
					    (intern (symbol-name karg)
						    (find-package :keyword))
					    karg)))
				      ( t (list karg)))))))
			  setf-ll))))))


;rob

  Robert C. Pettengill, MCC Software Technology Program
  P. O. Box 200195, Austin, Texas  78720
  ARPA:  rcp@mcc.com            PHONE:  (512) 338-3533
  UUCP:  {ihnp4,seismo,harvard,gatech,pyramid}!ut-sally!im4u!milano!rcp