Re: PCL bug (temp fix)

[Mike Thome <mthome@BBN.COM>]

	Turns out the bug I just reported is due to some confusion in the
method generic-function-pretty-arglist.  Below is a temporary patch to
fix the problem - notes are in comments in the code.
	-mike

;;; fix bug in generic-function-pretty-arglist - used to have severe problems with
;;; keywords and more than one method.  function-keywords used to only return the
;;; keywords of a function in the keyword package, but
;;; generic-function-pretty-arglist needed them in the same form as the actual
;;; arguments - this led to the pretty-arglist having &key arguments listed in both the
;;; regular package and in the keyword package.   MT 89-03-10
;;;  Note that we cannot just change function-keywords to return what we
;;; want as it's first argument, 'cuz it is used elsewhere correctly.
;;;
(defmethod generic-function-pretty-arglist
	   ((generic-function standard-generic-function))
  (let ((methods (generic-function-methods generic-function))
	(arglist ()))      
    (when methods
      (multiple-value-bind (required optional rest key allow-other-keys)
	  (method-pretty-arglist (car methods))
	(dolist (m (cdr methods))
	  (multiple-value-bind (method-key-keywords method-allow-other-keys method-key)
	      (function-keywords m)
	    ;; we've modified function-keywords to return what we want as
	    ;;  the third value, no other change here.
	    (declare (ignore method-key-keywords))
	    (setq key (union key method-key))
	    (setq allow-other-keys (or allow-other-keys
				       method-allow-other-keys))))
	(when allow-other-keys
	  (setq arglist '(&allow-other-keys)))
	(when key
	  (setq arglist (nconc (list '&key) key arglist)))
	(when rest
	  (setq arglist (nconc (list '&rest rest) arglist)))
	(when optional
	  (setq arglist (nconc (list '&optional) optional arglist)))
	(nconc required arglist)))))

(defmethod function-keywords ((method standard-method))
  (flet ((get-keyword-from-arg (arg)
	   (if (listp arg)
	       (if (listp (car arg))
		   (caar arg)
		   (make-keyword (car arg)))
	       (make-keyword arg))))
    (let ((keys ())
	  (syms ()) 			; also collect the args themselves
	  (allow-other-keys nil)
	  (state nil))
      (dolist (arg (method-arglist method))
	(if (memq arg lambda-list-keywords)
	    (case arg
	      (&key              (setq state 'key))
	      (&allow-other-keys (setq allow-other-keys 't)))
	    (when (eq state 'key)
	      (push (get-keyword-from-arg arg)
		    keys)
	      (push (if (listp arg)	; collect the args, too.
			(if (listp (car arg))
			    (caar arg)
			    (car arg))
			arg) syms))))
      ;; return the collected keyword *ARGS* as third value.
      (values (reverse keys) allow-other-keys (reverse syms)))))