Hi,
I am sending a new patch that improves arglist display and slime-complete-form. This patch supersedes the one from my message of Feb 22, which has not made it into CVS yet.
The patch integrates the code for detecting extra keyword arguments for generic functions into the arglist display in the echo area, as suggested by Luke. It also special-cases the keyword arguments :test and :test-not in slime-complete-form, as suggested by Christophe. For more details, see the changelog.
Anyone who wants to merge it into CVS?
Cheers, Matthias
2005-03-06 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de
* slime.el (slime-easy-menu): Add menu item for slime-complete-form.
* swank.lisp (format-arglist-for-echo-area): Use extra-keywords to enrich the list of keywords. (arglist-to-string): Remove extraneous whitespace. (keyword-arg, optional-arg): New structures. (decode-keyword-arg, decode-optional-arg): Return structure objects rather than multiple values. (encode-keyword-arg, encode-optional-arg, encode-arglist): New functions. (arglist): New slot key-p. (decode-arglist): Handle &whole, &environment. Store more information on optional and keyword args, set arglist.key-p. (values-equal?): Removed. (print-decoded-arglist-as-template): If keyword is not a keyword symbol, quote it in the template. (extra-keywords): Return a secondary value (allow-other-keys). For make-instance, try to finalize the class if it is not finalized yet (fix for Allegro CL 6.2). If class is not finalizable, use direct slots instead of slots and indicate that the keywords are not complete. (enrich-decoded-arglist-with-extra-keywords): New function, use the secondary value of extra-keywords. (arglist-for-insertion, complete-form): Use it here. (*remove-keywords-alist*): New variable. (remove-actual-args): When the keyword :test is provided, don't suggest :test-not and vice versa.
* swank-backend.lisp (:swank-mop package): Export finalize-inheritance.
Index: slime.el =================================================================== RCS file: /project/slime/cvsroot/slime/slime.el,v retrieving revision 1.463 diff -u -p -r1.463 slime.el --- slime.el 4 Mar 2005 23:43:29 -0000 1.463 +++ slime.el 6 Mar 2005 14:54:15 -0000 @@ -690,6 +690,7 @@ If INFERIOR is non-nil, the key is also [ "Return From Definition" slime-pop-find-definition-stack ,C ] [ "Complete Symbol" slime-complete-symbol ,C ] [ "Fuzzy Complete Symbol" slime-fuzzy-complete-symbol ,C ] + [ "Complete Form" slime-complete-form ,C ] [ "Show REPL" slime-switch-to-output-buffer ,C ] "--" ("Evaluation" Index: swank.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank.lisp,v retrieving revision 1.282 diff -u -p -r1.282 swank.lisp --- swank.lisp 28 Feb 2005 23:32:58 -0000 1.282 +++ swank.lisp 6 Mar 2005 14:54:17 -0000 @@ -1148,6 +1148,9 @@ Return the package or nil." (let ((symbol (parse-symbol string))) (valid-operator-symbol-p symbol)))
+ +;;;; Arglists + (defslimefun arglist-for-echo-area (names) "Return the arglist for the first function, macro, or special-op in NAMES." (handler-case @@ -1165,8 +1168,21 @@ Use the string NAME as operator name." ((member :not-available) nil) (list - (arglist-to-string (cons name arglist) - (symbol-package symbol)))))) + (let ((enriched-arglist + (if (extra-keywords symbol) + ;; When there are extra keywords, we decode the + ;; arglist, merge in the keywords and encode it + ;; again. + (let ((decoded-arglist (decode-arglist arglist))) + (enrich-decoded-arglist-with-extra-keywords + decoded-arglist (list symbol)) + (encode-arglist decoded-arglist)) + ;; Otherwise, just use the original arglist. + ;; This works better for implementation-specific + ;; lambda-list-keywords like CMUCL's &parse-body. + arglist))) + (arglist-to-string (cons name enriched-arglist) + (symbol-package symbol)))))))
(defun clean-arglist (arglist) "Remove &whole, &enviroment, and &aux elements from ARGLIST." @@ -1198,7 +1214,8 @@ pretty printing of (function foo) as #'f (string (princ arg)) (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")") (princ (car arg)) - (write-char #\space) + (unless (null (cdr arg)) + (write-char #\space)) (pprint-fill *standard-output* (cdr arg) nil)))) (when (null arglist) (return)) (write-char #\space) @@ -1227,65 +1244,106 @@ pretty printing of (function foo) as #'f (*print-length* 10) (*print-circle* t)) (format nil "~A => ~A" sym (symbol-value sym)))))))
+(defstruct (keyword-arg + (:conc-name keyword-arg.) + (:constructor make-keyword-arg (keyword arg-name default-arg))) + keyword + arg-name + default-arg) + (defun decode-keyword-arg (arg) "Decode a keyword item of formal argument list. Return three values: keyword, argument name, default arg." (cond ((symbolp arg) - (values (intern (symbol-name arg) keyword-package) - arg - nil)) + (make-keyword-arg (intern (symbol-name arg) keyword-package) + arg + nil)) ((and (consp arg) (consp (car arg))) - (values (caar arg) - (cadar arg) - (cadr arg))) + (make-keyword-arg (caar arg) + (cadar arg) + (cadr arg))) ((consp arg) - (values (intern (symbol-name (car arg)) keyword-package) - (car arg) - (cadr arg))) + (make-keyword-arg (intern (symbol-name (car arg)) keyword-package) + (car arg) + (cadr arg))) (t (error "Bad keyword item of formal argument list"))))
-(defmacro values-equal? (exp (&rest values)) - "Are the values produced by EXP equal to VALUES." - `(equal (multiple-value-list ,exp) (list ,@values))) +(defun encode-keyword-arg (arg) + (if (eql (intern (symbol-name (keyword-arg.arg-name arg)) + keyword-package) + (keyword-arg.keyword arg)) + (if (keyword-arg.default-arg arg) + (list (keyword-arg.arg-name arg) + (keyword-arg.default-arg arg)) + (keyword-arg.arg-name arg)) + (let ((keyword/name (list (keyword-arg.arg-name arg) + (keyword-arg.keyword arg)))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))))
(progn - (assert (values-equal? (decode-keyword-arg 'x) (:x 'x nil))) - (assert (values-equal? (decode-keyword-arg '(x t)) (:x 'x t))) - (assert (values-equal? (decode-keyword-arg '((:x y))) (:x 'y nil))) - (assert (values-equal? (decode-keyword-arg '((:x y) t)) (:x 'y t)))) + (assert (equalp (decode-keyword-arg 'x) + (make-keyword-arg :x 'x nil)) + (assert (equalp (decode-keyword-arg '(x t)) + (make-keyword-arg :x 'x t)))) + (assert (equalp (decode-keyword-arg '((:x y))) + (make-keyword-arg :x 'y nil))) + (assert (equalp (decode-keyword-arg '((:x y) t)) + (make-keyword-arg :x 'y t)))) + +(defstruct (optional-arg + (:conc-name optional-arg.) + (:constructor make-optional-arg (arg-name default-arg))) + arg-name + default-arg)
(defun decode-optional-arg (arg) "Decode an optional item of a formal argument list. -Return two values: argument name, default arg." +Return an OPTIONAL-ARG structure." (etypecase arg - (symbol (values arg nil)) - (list (values (car arg) (cadr arg))))) + (symbol (make-optional-arg arg nil)) + (list (make-optional-arg (car arg) (cadr arg))))) + +(defun encode-optional-arg (optional-arg) + (if (optional-arg.default-arg optional-arg) + (list (optional-arg.arg-name optional-arg) + (optional-arg.default-arg optional-arg)) + (optional-arg.arg-name optional-arg)))
(progn - (assert (values-equal? (decode-optional-arg 'x) ('x nil))) - (assert (values-equal? (decode-optional-arg '(x t)) ('x t)))) + (assert (equalp (decode-optional-arg 'x) + (make-optional-arg 'x nil))) + (assert (equalp (decode-optional-arg '(x t)) + (make-optional-arg 'x t))))
(defstruct (arglist (:conc-name arglist.)) required-args ; list of the required arguments optional-args ; list of the optional arguments + key-p ; whether &key appeared keyword-args ; list of the keywords rest ; name of the &rest or &body argument (if any) body-p ; whether the rest argument is a &body allow-other-keys-p) ; whether &allow-other-keys appeared
(defun decode-arglist (arglist) + "Parse the list ARGLIST and return an ARGLIST structure." (let ((mode nil) (result (make-arglist))) (dolist (arg arglist) - (typecase arg - ((member &key &optional &rest &body &whole &aux) - (setq mode arg)) - ((member &allow-other-keys) - (setf (arglist.allow-other-keys-p result) t)) - (t - (case mode + (cond + ((eql arg '&allow-other-keys) + (setf (arglist.allow-other-keys-p result) t)) + ((eql arg '&key) + (setf (arglist.key-p result) t + mode arg)) + ((member arg lambda-list-keywords) + (setq mode arg)) + (t + (case mode (&key (push (decode-keyword-arg arg) (arglist.keyword-args result))) @@ -1298,7 +1356,9 @@ Return two values: argument name, defaul (&rest (setf (arglist.rest result) arg)) ((nil) - (push arg (arglist.required-args result))))))) + (push arg (arglist.required-args result))) + ((&whole &environment) + (setf mode nil)))))) (setf (arglist.required-args result) (nreverse (arglist.required-args result))) (setf (arglist.optional-args result) @@ -1307,6 +1367,23 @@ Return two values: argument name, defaul (nreverse (arglist.keyword-args result))) result))
+(defun encode-arglist (decoded-arglist) + (append (arglist.required-args decoded-arglist) + (when (arglist.optional-args decoded-arglist) + '(&optional)) + (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist)) + (when (arglist.key-p decoded-arglist) + '(&key)) + (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist)) + (when (arglist.allow-other-keys-p decoded-arglist) + '(&allow-other-keys)) + (cond ((not (arglist.rest decoded-arglist)) + '()) + ((arglist.body-p decoded-arglist) + `(&body ,(arglist.rest decoded-arglist))) + (t + `(&rest ,(arglist.rest decoded-arglist)))))) + (defun arglist-keywords (arglist) "Return the list of keywords in ARGLIST. As a secondary value, return whether &allow-other-keys appears." @@ -1323,7 +1400,8 @@ As a secondary value, return whether &al (multiple-value-bind (kw aok) (arglist-keywords (swank-mop:method-lambda-list method)) - (setq keywords (remove-duplicates (append keywords kw)) + (setq keywords (remove-duplicates (append keywords kw) + :key #'keyword-arg.keyword) allow-other-keys (or allow-other-keys aok)))) (values keywords allow-other-keys)))
@@ -1367,10 +1445,14 @@ whether &allow-other-keys appears somewh (princ arg)) (dolist (arg (arglist.optional-args decoded-arglist)) (space) - (format t "[~A]" arg)) - (dolist (keyword (arglist.keyword-args decoded-arglist)) + (format t "[~A]" (optional-arg.arg-name arg))) + (dolist (keyword-arg (arglist.keyword-args decoded-arglist)) (space) - (format t "~W ~A" keyword keyword)) + (let ((arg-name (keyword-arg.arg-name keyword-arg)) + (keyword (keyword-arg.keyword keyword-arg))) + (format t "~W ~A" + (if (keywordp keyword) keyword `',keyword) + arg-name))) (when (and (arglist.rest decoded-arglist) (or (not (arglist.keyword-args decoded-arglist)) (arglist.allow-other-keys-p decoded-arglist))) @@ -1381,8 +1463,9 @@ whether &allow-other-keys appears somewh (pprint-newline :fill))
(defgeneric extra-keywords (operator &rest args) - (:documentation "Return a list of extra keywords of OPERATOR (a symbol) -when applied to the (unevaluated) ARGS.")) + (:documentation "Return a list of extra keywords of OPERATOR (a +symbol) when applied to the (unevaluated) ARGS. As a secondary value, +return whether other keys are allowed."))
(defmethod extra-keywords (operator &rest args) ;; default method @@ -1401,20 +1484,51 @@ when applied to the (unevaluated) ARGS." (eq (car class-name-form) 'quote)) (let* ((class-name (cadr class-name-form)) (class (find-class class-name nil))) + (unless (swank-mop:class-finalized-p class) + ;; Try to finalize the class, which can fail if + ;; superclasses are not defined yet + (handler-case (swank-mop:finalize-inheritance class) + (program-error (c) + (declare (ignore c))))) (when class ;; We have the case (make-instance 'CLASS ...) ;; with a known CLASS. - (let ((slot-init-keywords - (loop for slot in (swank-mop:class-slots class) - append (swank-mop:slot-definition-initargs slot))) - (initialize-instance-keywords - (applicable-methods-keywords #'initialize-instance - (list class)))) - (return-from extra-keywords - (append slot-init-keywords - initialize-instance-keywords)))))))) + (multiple-value-bind (slots allow-other-keys-p) + (if (swank-mop:class-finalized-p class) + (values (swank-mop:class-slots class) nil) + (values (swank-mop:class-direct-slots class) t)) + (let ((slot-init-keywords + (loop for slot in slots append + (mapcar (lambda (initarg) + (make-keyword-arg + initarg + initarg ; FIXME + (swank-mop:slot-definition-initform slot))) + (swank-mop:slot-definition-initargs slot)))) + (initialize-instance-keywords + (applicable-methods-keywords #'initialize-instance + (list class)))) + (return-from extra-keywords + (values (append slot-init-keywords + initialize-instance-keywords) + allow-other-keys-p))))))))) (call-next-method))
+(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form) + (multiple-value-bind (extra-keywords extra-aok) + (apply #'extra-keywords form) + ;; enrich the list of keywords with the extra keywords + (when extra-keywords + (setf (arglist.key-p decoded-arglist) t) + (setf (arglist.keyword-args decoded-arglist) + (remove-duplicates + (append (arglist.keyword-args decoded-arglist) + extra-keywords) + :key #'keyword-arg.keyword))) + (setf (arglist.allow-other-keys-p decoded-arglist) + (or (arglist.allow-other-keys-p decoded-arglist) extra-aok))) + decoded-arglist) + (defslimefun arglist-for-insertion (name) (with-buffer-syntax () (let ((symbol (parse-symbol name))) @@ -1426,18 +1540,18 @@ when applied to the (unevaluated) ARGS." ((member :not-available) :not-available) (list - (let ((decoded-arglist (decode-arglist arglist)) - (extra-keywords (extra-keywords symbol))) - ;; enrich the list of keywords with the extra keywords - (setf (arglist.keyword-args decoded-arglist) - (remove-duplicates - (append (arglist.keyword-args decoded-arglist) - extra-keywords))) + (let ((decoded-arglist (decode-arglist arglist))) + (enrich-decoded-arglist-with-extra-keywords decoded-arglist + (list symbol)) (decoded-arglist-to-template-string decoded-arglist *buffer-package*)))))) (t :not-available)))))
+(defvar *remove-keywords-alist* + '((:test :test-not) + (:test-not :test))) + (defun remove-actual-args (decoded-arglist actual-arglist) "Remove from DECODED-ARGLIST the arguments that have already been provided in ACTUAL-ARGLIST." @@ -1450,8 +1564,13 @@ provided in ACTUAL-ARGLIST." do (progn (pop actual-arglist) (pop (arglist.optional-args decoded-arglist)))) (loop for keyword in actual-arglist by #'cddr + for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*)) do (setf (arglist.keyword-args decoded-arglist) - (delete keyword (arglist.keyword-args decoded-arglist))))) + (remove-if (lambda (kw) + (or (eql kw keyword) + (member kw keywords-to-remove))) + (arglist.keyword-args decoded-arglist) + :key #'keyword-arg.keyword))))
(defslimefun complete-form (form-string) "Read FORM-STRING in the current buffer package, then complete it @@ -1469,13 +1588,8 @@ by adding a template for the missing arg ((member :not-available) :not-available) (list - (let ((decoded-arglist (decode-arglist arglist)) - (extra-keywords (apply #'extra-keywords form))) - ;; enrich the list of keywords with the extra keywords - (setf (arglist.keyword-args decoded-arglist) - (remove-duplicates - (append (arglist.keyword-args decoded-arglist) - extra-keywords))) + (let ((decoded-arglist (decode-arglist arglist))) + (enrich-decoded-arglist-with-extra-keywords decoded-arglist form) ;; get rid of formal args already provided (remove-actual-args decoded-arglist argument-forms) (return-from complete-form Index: swank-backend.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v retrieving revision 1.81 diff -u -p -r1.81 swank-backend.lisp --- swank-backend.lisp 28 Feb 2005 23:30:59 -0000 1.81 +++ swank-backend.lisp 6 Mar 2005 14:54:17 -0000 @@ -83,7 +83,8 @@ #:slot-definition-readers #:slot-definition-writers ;; generic function protocol - #:compute-applicable-methods-using-classes)) + #:compute-applicable-methods-using-classes + #:finalize-inheritance))
(in-package :swank-backend)