[slime-cvs] CVS slime

[mkoeppe]

Update of /project/slime/cvsroot/slime
In directory common-lisp:/tmp/cvs-serv21454

Modified Files:
	swank.lisp 
Log Message:
(operator-designator-to-form): New, factored out from
arglist-for-echo-area.
(arglist-for-echo-area): Use it here.
(completions-for-keyword): New.
(find-matching-symbols-in-list): New.


--- /project/slime/cvsroot/slime/swank.lisp	2006/02/10 16:54:58	1.361
+++ /project/slime/cvsroot/slime/swank.lisp	2006/02/21 06:44:52	1.362
@@ -1336,22 +1336,27 @@
                                (or (consp name)
                                    (valid-operator-name-p name)))
                              names)))
-          (etypecase name
-            (cons
-             (destructure-case name
-               ((:make-instance class-name)
-                (format-arglist-for-echo-area 
-                 `(make-instance ',(parse-symbol class-name))))
-               ((:defmethod generic-name)
-                (format-arglist-for-echo-area
-                 `(defmethod ,(parse-symbol generic-name))))))
-            (string
-             (let ((symbol (parse-symbol name)))
-               (format-arglist-for-echo-area `(,symbol) name)))
-            (null))))
+          (when name
+            (multiple-value-bind (form operator-name)
+                (operator-designator-to-form name)
+              (format-arglist-for-echo-area form operator-name)))))
     (error (cond)
       (format nil "ARGLIST: ~A" cond))))
 
+(defun operator-designator-to-form (name)
+  (etypecase name
+    (cons
+     (destructure-case name
+       ((:make-instance class-name)
+        (values `(make-instance ',(parse-symbol class-name))
+                'make-instance))
+       ((:defmethod generic-name)
+        (values `(defmethod ,(parse-symbol generic-name))
+                'defmethod))))
+    (string
+     (values `(,(parse-symbol name))
+             name))))
+
 (defun clean-arglist (arglist)
   "Remove &whole, &enviroment, and &aux elements from ARGLIST."
   (cond ((null arglist) '())
@@ -1857,6 +1862,33 @@
               *package*)))))))
   nil)
 
+(defslimefun completions-for-keyword (name keyword-string)
+  (with-buffer-syntax ()
+    (let* ((form (operator-designator-to-form name))
+           (operator-form (first form))
+           (argument-forms (rest form))
+           (arglist
+            (form-completion operator-form argument-forms
+                             :remove-args nil)))
+      (unless (eql arglist :not-available)
+        (let* ((keywords 
+                (mapcar #'keyword-arg.keyword
+                        (arglist.keyword-args arglist)))
+               (keyword-name
+                (tokenize-symbol keyword-string))
+               (matching-keywords
+                (find-matching-symbols-in-list keyword-name keywords
+                                               #'compound-prefix-match))
+               (converter (output-case-converter keyword-string))
+               (strings
+                (mapcar converter
+                        (mapcar #'symbol-name matching-keywords)))
+               (completion-set
+                (format-completion-set strings nil "")))
+          (list completion-set
+                (longest-completion completion-set)))))))
+           
+
 
 ;;;; Recording and accessing results of computations
 
@@ -2629,6 +2661,19 @@
           (push symbol completions))))
     (remove-duplicates completions)))
 
+(defun find-matching-symbols-in-list (string list test)
+  "Return a list of symbols in LIST matching STRING.
+TEST is called with two strings."
+  (let ((completions '())
+        (converter (output-case-converter string)))
+    (flet ((symbol-matches-p (symbol)
+             (funcall test string
+                      (funcall converter (symbol-name symbol)))))
+      (dolist (symbol list) 
+        (when (symbol-matches-p symbol)
+          (push symbol completions))))
+    (remove-duplicates completions)))
+
 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
   "True if SYMBOL is external in PACKAGE.
 If PACKAGE is not specified, the home package of SYMBOL is used."