Prettier generic function arglists

[Jamie.Zawinski <jwz@spice.cs.cmu.edu>]

A while back someone posted a suggestion for a way to get more readable
arglists from generic functions.  I thought that was a great idea, so, 
I wrote some code that does this. 

Say you do this:

(defmethod foo ((self class1) &rest rest-list &key a b &allow-other-keys)
  ... )

(defmethod foo ((self class2) &rest rest-list &key c (d 5) &allow-other-keys)
  ... )

(defmethod foo ((self class3) &rest other-stuff &key &allow-other-keys)
  ... )

Then, with the code that follows, the arglist of the generic function
FOO would be (SELF &REST OTHER-STUFF &KEY A B C D &ALLOW-OTHER-KEYS)
instead of (#:|Disc-Fn-Arg-0| &REST #:|Disc-Fn-&Rest-Arg|)

Making the world a safer place to hack,
		Jamie

--- like, cut here ---

;;; -*- Mode:Lisp; Syntax:Common-Lisp; Package:PCL -*-

;;; Prettier arglists in PCL

(in-package "PCL")

(defun parse-method-pretty-arglist (meth)
  "Given a STANDARD-METHOD, returns five values:
     a list of the required arguments;
     a list of the optional arguments;
     a symbol, the rest arg, or NIL;
     a list of the keyword arguments;
     T or NIL, whether &ALLOW-OTHER-KEYS was present.
   All elements of the returned lists will be symbols."
  (let* ((required ())
	 (optional ())
	 (rest nil)
	 (keywords ())
	 (allow-other-p nil)
	 (arglist (method-arglist meth))
	 (current-type :required))
    (dolist (token arglist)
      (case token
	(&optional (setq current-type :optional))
	(&rest (setq current-type :rest))
	(&key (setq current-type :keyword))
	(&allow-other-keys (setq allow-other-p t))
	(&aux (setq current-type :aux))
	(t (unless (member token LAMBDA-LIST-KEYWORDS :test #'eq)
	     ;; If we get a non-CommonLisp lambda-list keyword, we just 
	     ;; pretend it wasn't there:  (a &special b) ==> (a b)
	     (ecase current-type
	       (:required (push token required))
	       (:optional (push token optional))
	       (:rest (setq rest token))
	       (:keyword (push token keywords))
	       (:aux nil))))))
    (labels ((safe-car (x) (if (consp x) (safe-car (car x)) x)))
      ;; SAFE-CAR is to handle FOO and (FOO 5), as well as &KEY ((:FOO *FOO*) 5)
      (setq required (mapcar #'safe-car required))
      (setq optional (mapcar #'safe-car optional))
      (setq keywords (mapcar #'safe-car keywords)))
    (values (nreverse required)
	    (nreverse optional)
	    rest
	    (nreverse keywords)
	    allow-other-p)))


(defun generic-function-comprehensive-arglist (gf)
  "Returns a lambda list describing the generic function GF.
  This list is derived by looking at the arglists of all the methods."
  (let* ((required ())
	 (optional ())
	 (rest nil)
	 (keywords ())
	 (allow-other-keys-p nil))
    (dolist (meth (generic-function-methods gf))
      (multiple-value-bind (req opt rst key otherp)
	                   (parse-method-pretty-arglist meth)
	;; Since all methods must have parallel arglists, the following
	;; form is a little redundant.  KEYWORDS is really the only variable
	;; that must be set for each method.  But we set the others so we
        ;; (lazilly) don't have to special case the first or last iteration
        ;; through the loop.
	(setq required req
	      optional opt
	      rest (or rest rst)
	      keywords (nconc key keywords)
	      allow-other-keys-p (or allow-other-keys-p otherp))))
    (setq keywords (delete-duplicates keywords))
    (let* ((result required))
      (when optional (setq result (nconc result (cons '&optional optional))))
      (when rest (setq result (nconc result (list '&rest rest))))
      (when keywords (setq result (nconc result (cons '&key keywords))))
      (when allow-other-keys-p (setq result (nconc result (list '&allow-other-keys))))
      result)))

;;; The next bit will install this code into the ARGLIST function in
;;; Lucid Lisp.  It would probably be cooler if this code was instead
;;; hooked in to the place in PCL where the generic function's arglist is
;;; calculated, but I don't want to deal with figuring out where that is...
;;;
#+LUCID
(sys::defadvice (sys::arglist generic-function-arglist) (function)
  (when (symbolp function) (setq function (symbol-function function)))
  (if (generic-function-p function)
      (generic-function-comprehensive-arglist function)
      (sys::advice-continue function)))