completion of symbols

[hal@si.no (Hallvard Tretteberg)]

Newsgroups: comp.lang.lisp.mcl
Subject: completion
--text follows this line--
I hacked together code that adds completion of symbols to fred
windows. Perhaps others has done this before, too? There are two ways
of completing; completing symbols in the buffer package and thise it
inherits from and completing only from the COMMON-LISP package.
Suggestions, fixes etc. are welcome, especially for speeding it up and
limiting the search in the packages.

Here's the code:

(defun complete-string-against-strings-starting-with-string
       (string strings &key (test #'string-not-equal))
   (when strings
      (let* ((string1 (car strings)) (subpos (length string1)))
        (dolist (string2 (cdr strings))
	   (let ((pos (funcall test string1 string2 :end1 subpos)))
	     (when (and pos (< pos subpos))
		(setf subpos pos))))
        (values (subseq string1 (length string) subpos) strings)))
   )

(defun complete-string-against-strings
  (string strings &key (test #'string-not-equal))
  (let ((string-length (length string)))
    (flet ((starts-with-string-p (string2)
	      (let ((pos (funcall test string string2)))
		(when (or (not pos) (= pos string-length))
                   (values string2)))))
	(complete-string-against-strings-starting-with-string
	 string (remove-if (complement #'starts-with-string-p) strings)))
    ))

(defun complete-string-against-package-symbols
       (string package &key (test #'string-not-equal) (internalsp nil))
  (let ((string-length (length string)))
    (flet ((starts-with-string-p (string2)
             (let ((pos (funcall test string string2)))
               (when (or (not pos) (= pos string-length))
                 (values string2)))))
      (let ((strings nil))
        (flet ((do-symbols-body (symbol)
                 (when (starts-with-string-p (symbol-name symbol))
                   (push (symbol-name symbol) strings))))
          (if internalsp
            (do-symbols          (symbol package) (do-symbols-body symbol))
            (do-external-symbols (symbol package) (do-symbols-body symbol))
	    ))
        (complete-string-against-strings-starting-with-string string strings))
      )))

(defun force-same-case (string string2)
  (let ((alpha-string (remove-if (complement #'alpha-char-p) string)))
    (cond ((every #'lower-case-p alpha-string)
           (values (string-downcase string2)))
          ((every #'upper-case-p alpha-string)
           (values (string-upcase string2)))
          (t string2))))

(defun complete-buffer-word-fun (fred package)
  (let ((buffer (fred-buffer fred)))
    (multiple-value-bind (start end) (buffer-current-sexp-bounds buffer)
      (let* ((string (buffer-substring buffer end start))
             (first-colon-pos (position #\: string))
             (last-colon-pos first-colon-pos))
        (when first-colon-pos
          (setf package
		(find-package (nstring-upcase (subseq string 0 first-colon-pos))))
          (when (char= (char string (1+ first-colon-pos)) #\:)
            (incf last-colon-pos))
          (setf string (subseq string (1+ last-colon-pos))))
        (let* ((internalsp (or (not first-colon-pos)
			       (> last-colon-pos first-colon-pos)))
               (completion (complete-string-against-package-symbols
			    string package :internalsp internalsp)))
          (if completion
            (buffer-insert buffer (force-same-case string completion))
            (ccl::beep))))
      )))

;; completes in the buffer package and packages it inherits from
(defun complete-buffer-word (fred)
  (complete-buffer-word-fun fred (fred-package fred)))

;; completes in the COMMON-LISP package
(defun complete-buffer-word-from-common-lisp-package (fred)
  (complete-buffer-word-fun fred (find-package "COMMON-LISP")))

#|
(comtab-set-key *comtab* '(:meta #\Tab)   'complete-buffer-word)
(comtab-set-key *comtab* '(:meta #\Space) 'complete-buffer-word-from-common-lisp-package)
|#

--
Hallvard Traetteberg
Dept. of Knowledge Based Systems
SINTEF SI (Center for Industrial Research)
Box 124 Blindern, 0314 Oslo 3
NORWAY

Tlf: +47 2 45 29 83 or  +47 2 45 20 10
Fax: +47 2 45 20 40
Email: Hallvard.Tretteberg@si.sintef.no