[slime-devel] [Patch] Improve slime-insert-arglist for generic functions
Matthias Koeppe
mkoeppe+slime at mail.math.uni-magdeburg.de
Sun Feb 20 19:12:46 UTC 2005
Hi,
I am sending below a patch that extends the functionality of
slime-insert-arglist for generic functions, especially make-instance.
Cheers,
Matthias
2005-02-20 Matthias Koeppe <mkoeppe at mail.math.uni-magdeburg.de>
Supersede the command slime-insert-arglist with the new command
slime-complete-form and bind it to C-c C-s. The command completes
an incomplete form with a template for the missing arguments.
There is special code for discovering extra keywords of generic
functions and for handling make-instance. Examples:
(subseq "abc" <C-c C-s>
--inserts--> start [end])
(find 17 <C-c C-s>
--inserts--> sequence :from-end from-end :test test
:test-not test-not :start start :end end :key key)
(find 17 '(17 18 19) :test #'= <C-c C-s>
--inserts--> :from-end from-end
:test-not test-not :start start :end end :key key)
(defclass foo () ((bar :initarg :bar)))
(defmethod initialize-instance :after ((object foo) &key blub))
(make-instance 'foo <C-c C-s>
--inserts--> :bar bar :blub blub initargs...)
* swank.lisp (arglist): New struct for storing decoded arglists.
(decode-arglist): New function.
(arglist-keywords, methods-keywords, generic-function-keywords,
applicable-methods-keywords): New functions.
(decoded-arglist-to-template-string,
print-decoded-arglist-as-template): New functions.
(arglist-to-template-string): Rewrite using above functions.
(remove-actual-args): New function.
(complete-form): New slimefun.
* swank.lisp (extra-keywords): New generic function.
* swank-backend.lisp (:swank-mop package):
Export compute-applicable-methods-using-classes.
* swank.lisp (arglist-for-insertion): Use extra-keywords to
enrich the list of keywords.
* swank.lisp (valid-operator-symbol-p): New function.
(valid-operator-name-p): Use valid-operator-symbol-p.
* slime.el (slime-complete-form): New command.
(slime-keys): Bind C-c C-s to slime-complete-form rather than
slime-insert-arglist.
Index: slime.el
===================================================================
RCS file: /project/slime/cvsroot/slime/slime.el,v
retrieving revision 1.457
diff -u -p -r1.457 slime.el
--- slime.el 18 Feb 2005 16:01:53 -0000 1.457
+++ slime.el 20 Feb 2005 18:45:39 -0000
@@ -566,7 +566,7 @@ A prefix argument disables this behaviou
("\M-g" slime-quit :prefixed t :inferior t :sldb t)
;; Documentation
(" " slime-space :inferior t)
- ("\C-s" slime-insert-arglist :prefixed t :inferior t)
+ ("\C-s" slime-complete-form :prefixed t :inferior t)
("\C-f" slime-describe-function :prefixed t :inferior t :sldb t)
("\M-d" slime-disassemble-symbol :prefixed t :inferior t :sldb t)
("\C-t" slime-toggle-trace-fdefinition :prefixed t :sldb t)
@@ -4266,6 +4266,23 @@ currently looking at."
(t
(save-excursion
(insert arglist))))))
+
+(defun slime-complete-form ()
+ "Complete the form at point. This is a superset of the
+functionality of `slime-insert-arglist'."
+ (interactive)
+ ;; Find the (possibly incomplete) form around point.
+ (let* ((start (save-excursion (backward-up-list) (point)))
+ (end (point)) ; or try to find end (tricky)?
+ (form-string
+ (concat (buffer-substring-no-properties start end) ")")))
+ (let ((result (slime-eval `(swank:complete-form ,form-string))))
+ (if (eq result :not-available)
+ (error "Arglist not available")
+ (progn
+ (just-one-space)
+ (save-excursion
+ (insert result)))))))
(defun slime-get-arglist (symbol-name)
"Return the argument list for SYMBOL-NAME."
Index: swank-backend.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v
retrieving revision 1.78
diff -u -p -r1.78 swank-backend.lisp
--- swank-backend.lisp 18 Feb 2005 16:03:48 -0000 1.78
+++ swank-backend.lisp 20 Feb 2005 18:45:39 -0000
@@ -81,7 +81,9 @@
#:slot-definition-name
#:slot-definition-type
#:slot-definition-readers
- #:slot-definition-writers))
+ #:slot-definition-writers
+ ;; generic function protocol
+ #:compute-applicable-methods-using-classes))
(in-package :swank-backend)
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.279
diff -u -p -r1.279 swank.lisp
--- swank.lisp 18 Feb 2005 16:04:28 -0000 1.279
+++ swank.lisp 20 Feb 2005 18:45:41 -0000
@@ -1095,12 +1095,16 @@ Return the package or nil."
default)
default)))
+(defun valid-operator-symbol-p (symbol)
+ "Test if SYMBOL names a function, macro, or special-operator."
+ (or (fboundp symbol)
+ (macro-function symbol)
+ (special-operator-p symbol)))
+
(defun valid-operator-name-p (string)
"Test if STRING names a function, macro, or special-operator."
(let ((symbol (parse-symbol string)))
- (or (fboundp symbol)
- (macro-function symbol)
- (special-operator-p symbol))))
+ (valid-operator-symbol-p symbol)))
(defslimefun arglist-for-echo-area (names)
"Return the arglist for the first function, macro, or special-op in NAMES."
@@ -1221,51 +1225,224 @@ Return two values: argument name, defaul
(assert (values-equal? (decode-optional-arg 'x) ('x nil)))
(assert (values-equal? (decode-optional-arg '(x t)) ('x t))))
+(defstruct (arglist (:conc-name arglist.))
+ required-args ; list of the required arguments
+ optional-args ; list of the optional arguments
+ 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)
+ (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
+ (&key
+ (push (decode-keyword-arg arg)
+ (arglist.keyword-args result)))
+ (&optional
+ (push (decode-optional-arg arg)
+ (arglist.optional-args result)))
+ (&body
+ (setf (arglist.body-p result) t
+ (arglist.rest result) arg))
+ (&rest
+ (setf (arglist.rest result) arg))
+ ((nil)
+ (push arg (arglist.required-args result)))))))
+ (setf (arglist.required-args result)
+ (nreverse (arglist.required-args result)))
+ (setf (arglist.optional-args result)
+ (nreverse (arglist.optional-args result)))
+ (setf (arglist.keyword-args result)
+ (nreverse (arglist.keyword-args result)))
+ result))
+
+(defun arglist-keywords (arglist)
+ "Return the list of keywords in ARGLIST.
+As a secondary value, return whether &allow-other-keys appears."
+ (let ((decoded-arglist (decode-arglist arglist)))
+ (values (arglist.keyword-args decoded-arglist)
+ (arglist.allow-other-keys-p decoded-arglist))))
+
+(defun methods-keywords (methods)
+ "Collect all keywords in the arglists of METHODS.
+As a secondary value, return whether &allow-other-keys appears somewhere."
+ (let ((keywords '())
+ (allow-other-keys nil))
+ (dolist (method methods)
+ (multiple-value-bind (kw aok)
+ (arglist-keywords
+ (swank-mop:method-lambda-list method))
+ (setq keywords (remove-duplicates (append keywords kw))
+ allow-other-keys (or allow-other-keys aok))))
+ (values keywords allow-other-keys)))
+
+(defun generic-function-keywords (generic-function)
+ "Collect all keywords in the methods of GENERIC-FUNCTION.
+As a secondary value, return whether &allow-other-keys appears somewhere."
+ (methods-keywords
+ (swank-mop:generic-function-methods generic-function)))
+
+(defun applicable-methods-keywords (generic-function classes)
+ "Collect all keywords in the methods of GENERIC-FUNCTION that are
+applicable for argument of CLASSES. As a secondary value, return
+whether &allow-other-keys appears somewhere."
+ (methods-keywords
+ (swank-mop:compute-applicable-methods-using-classes generic-function classes)))
+
(defun arglist-to-template-string (arglist package)
"Print the list ARGLIST for insertion as a template for a function call."
- (setq arglist (clean-arglist arglist))
- (etypecase arglist
- (null "()")
- (cons
- (with-output-to-string (*standard-output*)
- (with-standard-io-syntax
- (let ((*package* package) (*print-case* :downcase)
- (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
- (*print-level* 10) (*print-length* 20))
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (arglist-to-template-string-aux arglist))))))))
+ (decoded-arglist-to-template-string
+ (decode-arglist arglist) package))
-(defun arglist-to-template-string-aux (arglist)
- (let ((mode nil))
- (loop
- (let ((arg (pop arglist)))
- (case arg
- ((&key &optional &rest &body)
- (setq mode arg))
- (t
- (case mode
- (&key (multiple-value-bind (key sym) (decode-keyword-arg arg)
- (format t "~W ~A" key sym)))
- (&optional (format t "[~A]" (decode-optional-arg arg)))
- (&body (format t "~:@_~A..." arg))
- (&rest (format t "~A..." arg))
- (otherwise (princ arg)))
- (unless (null arglist)
- (write-char #\space)))))
- (when (null arglist) (return))
- (pprint-newline :fill))))
+(defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
+ (with-output-to-string (*standard-output*)
+ (with-standard-io-syntax
+ (let ((*package* package) (*print-case* :downcase)
+ (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
+ (*print-level* 10) (*print-length* 20))
+ (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
+ (print-decoded-arglist-as-template decoded-arglist))))))
+
+(defun print-decoded-arglist-as-template (decoded-arglist)
+ (let ((first-p t))
+ (flet ((space ()
+ (unless first-p
+ (write-char #\space)
+ (pprint-newline :fill))
+ (setq first-p nil)))
+ (dolist (arg (arglist.required-args decoded-arglist))
+ (space)
+ (princ arg))
+ (dolist (arg (arglist.optional-args decoded-arglist))
+ (space)
+ (format t "[~A]" arg))
+ (dolist (keyword (arglist.keyword-args decoded-arglist))
+ (space)
+ (format t "~W ~A" keyword keyword))
+ (when (and (arglist.rest decoded-arglist)
+ (or (not (arglist.keyword-args decoded-arglist))
+ (arglist.allow-other-keys-p decoded-arglist)))
+ (if (arglist.body-p decoded-arglist)
+ (pprint-newline :mandatory)
+ (space))
+ (format t "~A..." (arglist.rest decoded-arglist)))))
+ (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."))
+
+(defmethod extra-keywords (operator &rest args)
+ ;; default method
+ (declare (ignore args))
+ (let ((symbol-function (symbol-function operator)))
+ (if (typep symbol-function 'generic-function)
+ (generic-function-keywords symbol-function)
+ nil)))
+
+(defmethod extra-keywords ((operator (eql 'make-instance))
+ &rest args)
+ (unless (null args)
+ (let ((class-name-form (car args)))
+ (when (and (listp class-name-form)
+ (= (length class-name-form) 2)
+ (eq (car class-name-form) 'quote))
+ (let* ((class-name (cadr class-name-form))
+ (class (find-class class-name nil)))
+ (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))))))))
+ (call-next-method))
(defslimefun arglist-for-insertion (name)
(with-buffer-syntax ()
- (cond ((valid-operator-name-p name)
- (let ((arglist (arglist (parse-symbol name))))
- (etypecase arglist
- ((member :not-available)
+ (let ((symbol (parse-symbol name)))
+ (cond
+ ((and symbol
+ (valid-operator-name-p name))
+ (let ((arglist (arglist symbol)))
+ (etypecase arglist
+ ((member :not-available)
:not-available)
- (list
- (arglist-to-template-string arglist *buffer-package*)))))
- (t
- :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)))
+ (decoded-arglist-to-template-string decoded-arglist
+ *buffer-package*))))))
+ (t
+ :not-available)))))
+
+(defun remove-actual-args (decoded-arglist actual-arglist)
+ "Remove from DECODED-ARGLIST the arguments that have already been
+provided in ACTUAL-ARGLIST."
+ (loop while (and actual-arglist
+ (arglist.required-args decoded-arglist))
+ do (progn (pop actual-arglist)
+ (pop (arglist.required-args decoded-arglist))))
+ (loop while (and actual-arglist
+ (arglist.optional-args decoded-arglist))
+ do (progn (pop actual-arglist)
+ (pop (arglist.optional-args decoded-arglist))))
+ (loop for keyword in actual-arglist by #'cddr
+ do (setf (arglist.keyword-args decoded-arglist)
+ (delete keyword (arglist.keyword-args decoded-arglist)))))
+
+(defslimefun complete-form (form-string)
+ "Read FORM-STRING in the current buffer package, then complete it
+by adding a template for the missing arguments."
+ (with-buffer-syntax ()
+ (handler-case
+ (let ((form (read-from-string form-string)))
+ (when (consp form)
+ (let ((operator-form (first form))
+ (argument-forms (rest form)))
+ (when (and (symbolp operator-form)
+ (valid-operator-symbol-p operator-form))
+ (let ((arglist (arglist operator-form)))
+ (etypecase arglist
+ ((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)))
+ ;; get rid of formal args already provided
+ (remove-actual-args decoded-arglist argument-forms)
+ (return-from complete-form
+ (decoded-arglist-to-template-string decoded-arglist
+ *buffer-package*
+ :prefix "")))))))))
+ :not-available)
+ (reader-error (c)
+ (declare (ignore c))
+ :not-available))))
;;;; Evaluation
--
Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe
More information about the slime-devel
mailing list